projects/guix·blob python-team · refs

328 lines · 12.8 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2021, 2022 Maxim Cournoyer <[email protected]>
3;;;
4;;; This file is part of GNU Guix.
5;;;
6;;; GNU Guix is free software; you can redistribute it and/or modify it
7;;; under the terms of the GNU General Public License as published by
8;;; the Free Software Foundation; either version 3 of the License, or (at
9;;; your option) any later version.
10;;;
11;;; GNU Guix is distributed in the hope that it will be useful, but
12;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
18
19;;; Commentary:
20;;;
21;;; This module contains helpers used as part of the jami-service-type
22;;; definition.
23;;;
24;;; Code:
25
26(define-module (gnu build jami-service)
27 #:use-module (gnu build dbus-service)
28 #:use-module (ice-9 format)
29 #:use-module (ice-9 match)
30 #:use-module (ice-9 rdelim)
31 #:use-module (ice-9 regex)
32 #:use-module (srfi srfi-1)
33 #:use-module (srfi srfi-26)
34 #:export (jami-service-available?
35
36 account-fingerprint?
37 account-details->recutil
38 get-accounts
39 get-usernames
40 set-account-details
41 add-account
42 account->username
43 username->account
44 username->contacts
45 enable-account
46 disable-account
47
48 add-contact
49 remove-contact
50
51 set-all-moderators
52 set-moderator
53 username->all-moderators?
54 username->moderators))
55
56;;;
57;;; Utilities.
58;;;
59
60(define (alist->list alist)
61 "Flatten ALIST into a list."
62 (append-map (match-lambda
63 (() '())
64 ((key . value)
65 (list key value)))
66 alist))
67
68(define account-fingerprint-rx (make-regexp "[0-9A-Fa-f]{40}"))
69
70(define (account-fingerprint? val)
71 "A Jami account fingerprint is 40 characters long and only contains
72hexadecimal characters."
73 (and (string? val)
74 (regexp-exec account-fingerprint-rx val)))
75
76(define (validate-fingerprint fingerprint)
77 "Validate that fingerprint is 40 characters long."
78 (unless (account-fingerprint? fingerprint)
79 (error "Account fingerprint is not valid:" fingerprint)))
80
81(define (jami-service-available?)
82 "Whether the Jami D-Bus service was acquired by the D-Bus daemon."
83 (unless (%current-dbus-connection)
84 (initialize-dbus-connection!))
85 (dbus-service-available? "cx.ring.Ring"))
86
87
88;;;
89;;; Bindings for the Jami D-Bus API.
90;;;
91
92(define* (call-configuration-manager-method method #:optional arguments
93 #:key timeout)
94 "Query the Jami D-Bus ConfigurationManager interface with METHOD applied to
95ARGUMENTS. TIMEOUT can optionally be provided as a value in seconds."
96 (unless (%current-dbus-connection)
97 (initialize-dbus-connection!))
98 (call-dbus-method method
99 #:path "/cx/ring/Ring/ConfigurationManager"
100 #:destination "cx.ring.Ring"
101 #:interface "cx.ring.Ring.ConfigurationManager"
102 #:arguments arguments
103 #:timeout timeout))
104
105;;; The following methods are for internal use; they make use of the account
106;;; ID, an implementation detail of Jami the user should not need to be
107;;; concerned with.
108(define (get-account-ids)
109 "Return the available Jami account identifiers (IDs). Account IDs are an
110implementation detail used to identify the accounts in Jami."
111 (vector->list (call-configuration-manager-method "getAccountList")))
112
113(define (id->account-details id)
114 "Retrieve the account data associated with the given account ID."
115 (vector->list (call-configuration-manager-method "getAccountDetails"
116 (list id))))
117
118(define (id->volatile-account-details id)
119 "Retrieve the account data associated with the given account ID."
120 (vector->list (call-configuration-manager-method "getVolatileAccountDetails"
121 (list id))))
122
123(define (id->account id)
124 "Retrieve the complete account data associated with the given account ID."
125 (append (id->volatile-account-details id)
126 (id->account-details id)))
127
128(define %username-to-id-cache #f)
129
130(define (invalidate-username-to-id-cache!)
131 (set! %username-to-id-cache #f))
132
133(define (username->id username)
134 "Return the first account ID corresponding to USERNAME."
135 (unless (assoc-ref %username-to-id-cache username)
136 (set! %username-to-id-cache
137 (append-map
138 (lambda (id)
139 (let* ((account (id->account id))
140 (username (assoc-ref account "Account.username"))
141 (registered-name (assoc-ref account
142 "Account.registeredName")))
143 `(,@(if username
144 (list (cons username id))
145 '())
146 ,@(if registered-name
147 (list (cons registered-name id))
148 '()))))
149 (get-account-ids))))
150 (or (assoc-ref %username-to-id-cache username)
151 (let ((message (format #f "no account ID for ~:[username~;fingerprint~]"
152 (account-fingerprint? username))))
153 (error message username))))
154
155(define (account->username account)
156 "Return the public key fingerprint of ACCOUNT."
157 (assoc-ref account "Account.username"))
158
159(define (id->username id)
160 "Return the public key fingerprint corresponding to account with ID, else #f."
161 (account->username (id->account id)))
162
163(define (get-accounts)
164 "Return the list of all accounts, as a list of alists."
165 (map id->account (get-account-ids)))
166
167(define (get-usernames)
168 "Return the list of the usernames associated with the present accounts."
169 (map account->username (get-accounts)))
170
171(define (username->account username)
172 "Return the first account associated with USERNAME, else #f.
173USERNAME can be either the account 40 characters public key fingerprint or a
174registered username."
175 (find (lambda (account)
176 (member username
177 (list (assoc-ref account "Account.username")
178 (assoc-ref account "Account.registeredName"))))
179 (get-accounts)))
180
181(define (add-account archive)
182 "Import the Jami account ARCHIVE and return its account ID. The archive
183should *not* be encrypted with a password. Return the username associated
184with the account."
185 (invalidate-username-to-id-cache!)
186 (let ((id (call-configuration-manager-method
187 "addAccount" (list `#(("Account.archivePath" . ,archive)
188 ("Account.type" . "RING"))))))
189 ;; The account information takes some time to be populated.
190 (with-retries 20 1
191 (let ((username (id->username id)))
192 (if (and=> username (negate string-null?))
193 username
194 #f)))))
195
196(define (remove-account username)
197 "Delete the Jami account associated with USERNAME, the account 40 characters
198fingerprint or a registered username."
199 (let ((id (username->id username)))
200 (call-configuration-manager-method "removeAccount" (list id)))
201 (invalidate-username-to-id-cache!))
202
203(define* (username->contacts username)
204 "Return the contacts associated with the account of USERNAME as two values;
205the first one being the regular contacts and the second one the banned
206contacts. USERNAME can be either the account 40 characters public key
207fingerprint or a registered username. The contacts returned are represented
208using their 40 characters fingerprint."
209 (let* ((id (username->id username))
210 ;; The contacts are returned as "aa{ss}", that is, an array of arrays
211 ;; containing (string . string) pairs.
212 (contacts (map vector->list
213 (vector->list (call-configuration-manager-method
214 "getContacts" (list id)))))
215 (banned? (lambda (contact)
216 (and=> (assoc-ref contact "banned")
217 (cut string=? "true" <>))))
218 (banned (filter banned? contacts))
219 (not-banned (filter (negate banned?) contacts))
220 (fingerprint (cut assoc-ref <> "id")))
221 (values (map fingerprint not-banned)
222 (map fingerprint banned))))
223
224(define* (remove-contact contact username #:key ban?)
225 "Remove CONTACT, the 40 characters public key fingerprint of a contact, from
226the account associated with USERNAME (either a fingerprint or a registered
227username). When BAN? is true, also mark the contact as banned."
228 (validate-fingerprint contact)
229 (let ((id (username->id username)))
230 (call-configuration-manager-method "removeContact" (list id contact ban?))))
231
232(define (add-contact contact username)
233 "Add CONTACT, the 40 characters public key fingerprint of a contact, to the
234account of USERNAME (either a fingerprint or a registered username)."
235 (validate-fingerprint contact)
236 (let ((id (username->id username)))
237 (call-configuration-manager-method "addContact" (list id contact))))
238
239(define* (set-account-details details username #:key timeout)
240 "Set DETAILS, an alist containing the key value pairs to set for the account
241of USERNAME, a registered username or account fingerprint. The value of the
242parameters not provided are unchanged. TIMEOUT is a value in milliseconds to
243pass to the `call-configuration-manager-method' procedure."
244 (let* ((id (username->id username))
245 (current-details (id->account-details id))
246 (updated-details (map (match-lambda
247 ((key . value)
248 (or (and=> (assoc-ref details key)
249 (cut cons key <>))
250 (cons key value))))
251 current-details)))
252 (call-configuration-manager-method
253 "setAccountDetails" (list id (list->vector updated-details))
254 #:timeout timeout)))
255
256(define (set-all-moderators enabled? username)
257 "Set the 'AllModerators' property to enabled? for the account of USERNAME, a
258registered username or account fingerprint."
259 (let ((id (username->id username)))
260 (call-configuration-manager-method "setAllModerators" (list id enabled?))))
261
262(define (username->all-moderators? username)
263 "Return the 'AllModerators' property for the account of USERNAME, a
264registered username or account fingerprint."
265 (let ((id (username->id username)))
266 (call-configuration-manager-method "isAllModerators" (list id))))
267
268(define (username->moderators username)
269 "Return the moderators for the account of USERNAME, a registered username or
270account fingerprint."
271 (let* ((id (username->id username)))
272 (vector->list (call-configuration-manager-method "getDefaultModerators"
273 (list id)))))
274
275(define (set-moderator contact enabled? username)
276 "Set the moderator flag to ENABLED? for CONTACT, the 40 characters public
277key fingerprint of a contact for the account of USERNAME, a registered
278username or account fingerprint."
279 (validate-fingerprint contact)
280 (let* ((id (username->id username)))
281 (call-configuration-manager-method "setDefaultModerator"
282 (list id contact enabled?))))
283
284(define (disable-account username)
285 "Disable the account known by USERNAME, a registered username or account
286fingerprint."
287 (set-account-details '(("Account.enable" . "false")) username
288 ;; Waiting for the reply on this command takes a very
289 ;; long time that trips the default D-Bus timeout value
290 ;; (25 s), for some reason.
291 #:timeout 60))
292
293(define (enable-account username)
294 "Enable the account known by USERNAME, a registered username or account
295fingerprint."
296 (set-account-details '(("Account.enable" . "true")) username))
297
298
299;;;
300;;; Presentation procedures.
301;;;
302
303(define (.->_ text)
304 "Map each period character to underscore characters."
305 (string-map (match-lambda
306 (#\. #\_)
307 (c c))
308 text))
309
310(define (account-details->recutil account-details)
311 "Serialize the account-details alist into a recutil string. Period
312characters in the keys are normalized to underscore to meet Recutils' format
313requirements."
314 (define (pair->recutil-property pair)
315 (match pair
316 ((key . value)
317 (string-append (.->_ key) ": " value))))
318
319 (define sorted-account-details
320 ;; Have the account username, display name and alias appear first, for
321 ;; convenience.
322 (let ((first-items '("Account.username"
323 "Account.displayName"
324 "Account.alias")))
325 (append (map (cut assoc <> account-details) first-items)
326 (fold alist-delete account-details first-items))))
327
328 (string-join (map pair->recutil-property sorted-account-details) "\n"))