aboutsummaryrefslogtreecommitdiff
path: root/gnu/build/jami-service.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/build/jami-service.scm')
-rw-r--r--gnu/build/jami-service.scm587
1 files changed, 587 insertions, 0 deletions
diff --git a/gnu/build/jami-service.scm b/gnu/build/jami-service.scm
new file mode 100644
index 0000000000..d44e87387d
--- /dev/null
+++ b/gnu/build/jami-service.scm
@@ -0,0 +1,587 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 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 helpers used as part of the jami-service-type
+;;; definition.
+;;;
+;;; Code:
+
+(define-module (gnu build jami-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?
+ account-details->recutil
+ get-accounts
+ get-usernames
+ set-account-details
+ add-account
+ account->username
+ username->account
+ username->contacts
+ enable-account
+ disable-account
+
+ add-contact
+ remove-contact
+
+ 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))
+
+;;;
+;;; 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
+ (() '())
+ ((key . value)
+ (list key value)))
+ alist))
+
+(define account-fingerprint-rx (make-regexp "[0-9A-f]{40}"))
+
+(define (account-fingerprint? val)
+ "A Jami account fingerprint is 40 characters long and only contains
+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.
+;;;
+
+;;; 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 (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))
+
+;;; 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
+;;; concerned with.
+(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")))
+
+(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)))))
+
+(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)))))
+
+(define (id->account id)
+ "Retrieve the complete account data associated with the given account ID."
+ (append (id->volatile-account-details id)
+ (id->account-details id)))
+
+(define %username-to-id-cache #f)
+
+(define (invalidate-username-to-id-cache!)
+ (set! %username-to-id-cache #f))
+
+(define (username->id username)
+ "Return the first account ID corresponding to USERNAME."
+ (unless (assoc-ref %username-to-id-cache username)
+ (set! %username-to-id-cache
+ (append-map
+ (lambda (id)
+ (let* ((account (id->account id))
+ (username (assoc-ref account "Account.username"))
+ (registered-name (assoc-ref account
+ "Account.registeredName")))
+ `(,@(if username
+ (list (cons username id))
+ '())
+ ,@(if registered-name
+ (list (cons registered-name id))
+ '()))))
+ (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))))
+ (error message username))))
+
+(define (account->username account)
+ "Return USERNAME, the registered username associated with ACCOUNT, else its
+public key fingerprint."
+ (or (assoc-ref account "Account.registeredName")
+ (assoc-ref account "Account.username")))
+
+(define (id->username id)
+ "Return USERNAME, the registered username associated with ID, else its
+public key fingerprint, else #f."
+ (account->username (id->account id)))
+
+(define (get-accounts)
+ "Return the list of all accounts, as a list of alists."
+ (map id->account (get-account-ids)))
+
+(define (get-usernames)
+ "Return the list of the usernames associated with the present accounts."
+ (map account->username (get-accounts)))
+
+(define (username->account username)
+ "Return the first account associated with USERNAME, else #f.
+USERNAME can be either the account 40 characters public key fingerprint or a
+registered username."
+ (find (lambda (account)
+ (member username
+ (list (assoc-ref account "Account.username")
+ (assoc-ref account "Account.registeredName"))))
+ (get-accounts)))
+
+(define (add-account archive)
+ "Import the Jami account ARCHIVE and return its account ID. The 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")))))
+ ;; 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))))))
+
+(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))))
+ (invalidate-username-to-id-cache!))
+
+(define* (username->contacts username)
+ "Return the contacts associated with the account of USERNAME as two values;
+the first one being the regular contacts and the second one the banned
+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))
+ (banned? (lambda (contact)
+ (and=> (assoc-ref contact "banned")
+ (cut string=? "true" <>))))
+ (banned (filter banned? all-contacts))
+ (not-banned (filter (negate banned?) all-contacts))
+ (fingerprint (cut assoc-ref <> "id")))
+ (values (map fingerprint not-banned)
+ (map fingerprint banned))))
+
+(define* (remove-contact contact username #:key ban?)
+ "Remove CONTACT, the 40 characters public key fingerprint of a contact, from
+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?)))))
+
+(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)))))
+
+(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."
+ (let* ((id (username->id username))
+ (current-details (id->account-details id))
+ (updated-details (map (match-lambda
+ ((key . value)
+ (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*)
+ ","))))))
+
+(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?)))))
+
+(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))))
+
+(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))))
+
+(define (set-moderator contact enabled? username)
+ "Set the moderator flag to ENABLED? for CONTACT, the 40 characters public
+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?)))))
+
+(define (disable-account username)
+ "Disable the account known by USERNAME, a registered username or account
+fingerprint."
+ (set-account-details '(("Account.enable" . "false")) 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))
+
+(define (enable-account username)
+ "Enable the account known by USERNAME, a registered username or account
+fingerprint."
+ (set-account-details '(("Account.enable" . "true")) username))
+
+
+;;;
+;;; Presentation procedures.
+;;;
+
+(define (.->_ text)
+ "Map each period character to underscore characters."
+ (string-map (match-lambda
+ (#\. #\_)
+ (c c))
+ text))
+
+(define (account-details->recutil account-details)
+ "Serialize the account-details alist into a recutil string. Period
+characters in the keys are normalized to underscore to meet Recutils' format
+requirements."
+ (define (pair->recutil-property pair)
+ (match pair
+ ((key . value)
+ (string-append (.->_ key) ": " value))))
+
+ (define sorted-account-details
+ ;; Have the account username, display name and alias appear first, for
+ ;; convenience.
+ (let ((first-items '("Account.username"
+ "Account.displayName"
+ "Account.alias")))
+ (append (map (cut assoc <> account-details) first-items)
+ (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:
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-18 20:05:20 +0000