Commit | Line | Data |
---|---|---|
10f55470 MC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> | |
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 (ice-9 format) | |
28 | #:use-module (ice-9 match) | |
29 | #:use-module (ice-9 peg) | |
30 | #:use-module (ice-9 rdelim) | |
31 | #:use-module (ice-9 regex) | |
32 | #:use-module (rnrs io ports) | |
33 | #:autoload (shepherd service) (fork+exec-command) | |
34 | #:use-module (srfi srfi-1) | |
35 | #:use-module (srfi srfi-26) | |
36 | #:export (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 | dbus-available-services | |
57 | dbus-service-available? | |
58 | ||
59 | %send-dbus-binary | |
60 | %send-dbus-bus | |
61 | %send-dbus-user | |
62 | %send-dbus-group | |
63 | %send-dbus-debug | |
64 | send-dbus | |
65 | ||
66 | with-retries)) | |
67 | ||
68 | ;;; | |
69 | ;;; Utilities. | |
70 | ;;; | |
71 | ||
72 | (define-syntax-rule (with-retries n delay body ...) | |
73 | "Retry the code in BODY up to N times until it doesn't raise an exception | |
74 | nor return #f, else raise an error. A delay of DELAY seconds is inserted | |
75 | before each retry." | |
76 | (let loop ((attempts 0)) | |
77 | (catch #t | |
78 | (lambda () | |
79 | (let ((result (begin body ...))) | |
80 | (if (not result) | |
81 | (error "failed attempt" attempts) | |
82 | result))) | |
83 | (lambda args | |
84 | (if (< attempts n) | |
85 | (begin | |
86 | (sleep delay) ;else wait and retry | |
87 | (loop (+ 1 attempts))) | |
88 | (error "maximum number of retry attempts reached" | |
89 | body ... args)))))) | |
90 | ||
91 | (define (alist->list alist) | |
92 | "Flatten ALIST into a list." | |
93 | (append-map (match-lambda | |
94 | (() '()) | |
95 | ((key . value) | |
96 | (list key value))) | |
97 | alist)) | |
98 | ||
99 | (define account-fingerprint-rx (make-regexp "[0-9A-f]{40}")) | |
100 | ||
101 | (define (account-fingerprint? val) | |
102 | "A Jami account fingerprint is 40 characters long and only contains | |
103 | hexadecimal characters." | |
104 | (and (string? val) | |
105 | (regexp-exec account-fingerprint-rx val))) | |
106 | ||
107 | \f | |
108 | ;;; | |
109 | ;;; D-Bus reply parser. | |
110 | ;;; | |
111 | ||
112 | (define (parse-dbus-reply reply) | |
113 | "Return the parse tree of REPLY, a string returned by the 'dbus-send' | |
114 | command." | |
115 | ;; Refer to 'man 1 dbus-send' for the grammar reference. Note that the | |
116 | ;; format of the replies doesn't match the format of the input, which is the | |
117 | ;; one documented, but it gives an idea. For an even better reference, see | |
118 | ;; the `print_iter' procedure of the 'dbus-print-message.c' file from the | |
119 | ;; 'dbus' package sources. | |
120 | (define-peg-string-patterns | |
121 | "contents <- header (item / container (item / container*)?) | |
122 | item <-- WS type WS value NL | |
123 | container <- array / dict / variant | |
124 | array <-- array-start (item / container)* array-end | |
125 | dict <-- array-start dict-entry* array-end | |
126 | dict-entry <-- dict-entry-start item item dict-entry-end | |
127 | variant <-- variant-start item | |
128 | type <-- 'string' / 'int16' / 'uint16' / 'int32' / 'uint32' / 'int64' / | |
129 | 'uint64' / 'double' / 'byte' / 'boolean' / 'objpath' | |
130 | value <-- (!NL .)* NL | |
131 | header < (!NL .)* NL | |
132 | variant-start < WS 'variant' | |
133 | array-start < WS 'array [' NL | |
134 | array-end < WS ']' NL | |
135 | dict-entry-start < WS 'dict entry(' NL | |
136 | dict-entry-end < WS ')' NL | |
137 | DQ < '\"' | |
138 | WS < ' '* | |
139 | NL < '\n'*") | |
140 | ||
141 | (peg:tree (match-pattern contents reply))) | |
142 | ||
143 | (define (strip-quotes text) | |
144 | "Strip the leading and trailing double quotes (\") characters from TEXT." | |
145 | (let* ((text* (if (string-prefix? "\"" text) | |
146 | (string-drop text 1) | |
147 | text)) | |
148 | (text** (if (string-suffix? "\"" text*) | |
149 | (string-drop-right text* 1) | |
150 | text*))) | |
151 | text**)) | |
152 | ||
153 | (define (deserialize-item item) | |
154 | "Return the value described by the ITEM parse tree as a Guile object." | |
155 | ;; Strings are printed wrapped in double quotes (see the print_iter | |
156 | ;; procedure in dbus-print-message.c). | |
157 | (match item | |
158 | (('item ('type "string") ('value value)) | |
159 | (strip-quotes value)) | |
160 | (('item ('type "boolean") ('value value)) | |
161 | (if (string=? "true" value) | |
162 | #t | |
163 | #f)) | |
164 | (('item _ ('value value)) | |
165 | value))) | |
166 | ||
167 | (define (serialize-boolean bool) | |
168 | "Return the serialized format expected by dbus-send for BOOL." | |
169 | (format #f "boolean:~:[false~;true~]" bool)) | |
170 | ||
171 | (define (dict->alist dict-parse-tree) | |
172 | "Translate a dict parse tree to an alist." | |
173 | (define (tuples->alist tuples) | |
174 | (map (lambda (x) (apply cons x)) tuples)) | |
175 | ||
176 | (match dict-parse-tree | |
177 | ('dict | |
178 | '()) | |
179 | (('dict ('dict-entry keys values) ...) | |
180 | (let ((keys* (map deserialize-item keys)) | |
181 | (values* (map deserialize-item values))) | |
182 | (tuples->alist (zip keys* values*)))))) | |
183 | ||
184 | (define (array->list array-parse-tree) | |
185 | "Translate an array parse tree to a list." | |
186 | (match array-parse-tree | |
187 | ('array | |
188 | '()) | |
189 | (('array items ...) | |
190 | (map deserialize-item items)))) | |
191 | ||
192 | \f | |
193 | ;;; | |
194 | ;;; Low-level, D-Bus-related procedures. | |
195 | ;;; | |
196 | ||
197 | ;;; The following parameters are used in the jami-service-type service | |
198 | ;;; definition to conveniently customize the behavior of the send-dbus helper, | |
199 | ;;; even when called indirectly. | |
200 | (define %send-dbus-binary (make-parameter "dbus-send")) | |
201 | (define %send-dbus-bus (make-parameter #f)) | |
202 | (define %send-dbus-user (make-parameter #f)) | |
203 | (define %send-dbus-group (make-parameter #f)) | |
204 | (define %send-dbus-debug (make-parameter #f)) | |
205 | ||
206 | (define* (send-dbus #:key service path interface method | |
207 | bus | |
208 | dbus-send | |
209 | user group | |
210 | timeout | |
211 | arguments) | |
212 | "Return the response of DBUS-SEND, else raise an error. Unless explicitly | |
213 | provided, DBUS-SEND takes the value of the %SEND-DBUS-BINARY parameter. BUS | |
214 | can be used to specify the bus address, such as 'unix:path=/var/run/jami/bus'. | |
215 | Alternatively, the %SEND-DBUS-BUS parameter can be used. ARGUMENTS can be | |
216 | used to pass input values to a D-Bus method call. TIMEOUT is the amount of | |
217 | time to wait for a reply in milliseconds before giving up with an error. USER | |
218 | and GROUP allow choosing under which user/group the DBUS-SEND command is | |
219 | executed. Alternatively, the %SEND-DBUS-USER and %SEND-DBUS-GROUP parameters | |
220 | can be used instead." | |
221 | (let* ((command `(,(if dbus-send | |
222 | dbus-send | |
223 | (%send-dbus-binary)) | |
224 | ,@(if (or bus (%send-dbus-bus)) | |
225 | (list (string-append "--bus=" | |
226 | (or bus (%send-dbus-bus)))) | |
227 | '()) | |
228 | "--print-reply" | |
229 | ,@(if timeout | |
230 | (list (format #f "--reply-timeout=~d" timeout)) | |
231 | '()) | |
232 | ,(string-append "--dest=" service) ;e.g., cx.ring.Ring | |
233 | ,path ;e.g., /cx/ring/Ring/ConfigurationManager | |
234 | ,(string-append interface "." method) | |
235 | ,@(or arguments '()))) | |
236 | (temp-port (mkstemp! (string-copy "/tmp/dbus-send-output-XXXXXXX"))) | |
237 | (temp-file (port-filename temp-port))) | |
238 | (dynamic-wind | |
239 | (lambda () | |
240 | (let* ((uid (or (and=> (or user (%send-dbus-user)) | |
241 | (compose passwd:uid getpwnam)) -1)) | |
242 | (gid (or (and=> (or group (%send-dbus-group)) | |
243 | (compose group:gid getgrnam)) -1))) | |
244 | (chown temp-port uid gid))) | |
245 | (lambda () | |
246 | (let ((pid (fork+exec-command command | |
247 | #:user (or user (%send-dbus-user)) | |
248 | #:group (or group (%send-dbus-group)) | |
249 | #:log-file temp-file))) | |
250 | (match (waitpid pid) | |
251 | ((_ . status) | |
252 | (let ((exit-status (status:exit-val status)) | |
253 | (output (call-with-port temp-port get-string-all))) | |
254 | (if (= 0 exit-status) | |
255 | output | |
256 | (error "the send-dbus command exited with: " | |
257 | command exit-status output))))))) | |
258 | (lambda () | |
259 | (false-if-exception (delete-file temp-file)))))) | |
260 | ||
261 | (define (parse-account-ids reply) | |
262 | "Return the Jami account IDs from REPLY, which is assumed to be the output | |
263 | of the Jami D-Bus `getAccountList' method." | |
264 | (array->list (parse-dbus-reply reply))) | |
265 | ||
266 | (define (parse-account-details reply) | |
267 | "Parse REPLY, which is assumed to be the output of the Jami D-Bus | |
268 | `getAccountDetails' method, and return its content as an alist." | |
269 | (dict->alist (parse-dbus-reply reply))) | |
270 | ||
271 | (define (parse-contacts reply) | |
272 | "Parse REPLY, which is assumed to be the output of the Jamid D-Bus | |
273 | `getContacts' method, and return its content as an alist." | |
274 | (match (parse-dbus-reply reply) | |
275 | ('array | |
276 | '()) | |
277 | (('array dicts ...) | |
278 | (map dict->alist dicts)))) | |
279 | ||
280 | \f | |
281 | ;;; | |
282 | ;;; Higher-level, D-Bus-related procedures. | |
283 | ;;; | |
284 | ||
285 | (define (validate-fingerprint fingerprint) | |
286 | "Validate that fingerprint is 40 characters long." | |
287 | (unless (account-fingerprint? fingerprint) | |
288 | (error "Account fingerprint is not valid:" fingerprint))) | |
289 | ||
290 | (define (dbus-available-services) | |
291 | "Return the list of available (acquired) D-Bus services." | |
292 | (let ((reply (parse-dbus-reply | |
293 | (send-dbus #:service "org.freedesktop.DBus" | |
294 | #:path "/org/freedesktop/DBus" | |
295 | #:interface "org.freedesktop.DBus" | |
296 | #:method "ListNames")))) | |
297 | ;; Remove entries such as ":1.7". | |
298 | (remove (cut string-prefix? ":" <>) | |
299 | (array->list reply)))) | |
300 | ||
301 | (define (dbus-service-available? service) | |
302 | "Predicate to check for the D-Bus SERVICE availability." | |
303 | (member service (dbus-available-services))) | |
304 | ||
305 | (define* (send-dbus/configuration-manager #:key method arguments timeout) | |
306 | "Query the Jami D-Bus ConfigurationManager service." | |
307 | (send-dbus #:service "cx.ring.Ring" | |
308 | #:path "/cx/ring/Ring/ConfigurationManager" | |
309 | #:interface "cx.ring.Ring.ConfigurationManager" | |
310 | #:method method | |
311 | #:arguments arguments | |
312 | #:timeout timeout)) | |
313 | ||
314 | ;;; The following methods are for internal use; they make use of the account | |
315 | ;;; ID, an implementation detail of Jami the user should not need to be | |
316 | ;;; concerned with. | |
317 | (define (get-account-ids) | |
318 | "Return the available Jami account identifiers (IDs). Account IDs are an | |
319 | implementation detail used to identify the accounts in Jami." | |
320 | (parse-account-ids | |
321 | (send-dbus/configuration-manager #:method "getAccountList"))) | |
322 | ||
323 | (define (id->account-details id) | |
324 | "Retrieve the account data associated with the given account ID." | |
325 | (parse-account-details | |
326 | (send-dbus/configuration-manager | |
327 | #:method "getAccountDetails" | |
328 | #:arguments (list (string-append "string:" id))))) | |
329 | ||
330 | (define (id->volatile-account-details id) | |
331 | "Retrieve the account data associated with the given account ID." | |
332 | (parse-account-details | |
333 | (send-dbus/configuration-manager | |
334 | #:method "getVolatileAccountDetails" | |
335 | #:arguments (list (string-append "string:" id))))) | |
336 | ||
337 | (define (id->account id) | |
338 | "Retrieve the complete account data associated with the given account ID." | |
339 | (append (id->volatile-account-details id) | |
340 | (id->account-details id))) | |
341 | ||
342 | (define %username-to-id-cache #f) | |
343 | ||
344 | (define (invalidate-username-to-id-cache!) | |
345 | (set! %username-to-id-cache #f)) | |
346 | ||
347 | (define (username->id username) | |
348 | "Return the first account ID corresponding to USERNAME." | |
349 | (unless (assoc-ref %username-to-id-cache username) | |
350 | (set! %username-to-id-cache | |
351 | (append-map | |
352 | (lambda (id) | |
353 | (let* ((account (id->account id)) | |
354 | (username (assoc-ref account "Account.username")) | |
355 | (registered-name (assoc-ref account | |
356 | "Account.registeredName"))) | |
357 | `(,@(if username | |
358 | (list (cons username id)) | |
359 | '()) | |
360 | ,@(if registered-name | |
361 | (list (cons registered-name id)) | |
362 | '())))) | |
363 | (get-account-ids)))) | |
364 | (or (assoc-ref %username-to-id-cache username) | |
365 | (let ((message (format #f "Could not retrieve a local account ID\ | |
366 | for ~:[username~;fingerprint~]" (account-fingerprint? username)))) | |
367 | (error message username)))) | |
368 | ||
369 | (define (account->username account) | |
370 | "Return USERNAME, the registered username associated with ACCOUNT, else its | |
371 | public key fingerprint." | |
372 | (or (assoc-ref account "Account.registeredName") | |
373 | (assoc-ref account "Account.username"))) | |
374 | ||
375 | (define (id->username id) | |
376 | "Return USERNAME, the registered username associated with ID, else its | |
377 | public key fingerprint, else #f." | |
378 | (account->username (id->account id))) | |
379 | ||
380 | (define (get-accounts) | |
381 | "Return the list of all accounts, as a list of alists." | |
382 | (map id->account (get-account-ids))) | |
383 | ||
384 | (define (get-usernames) | |
385 | "Return the list of the usernames associated with the present accounts." | |
386 | (map account->username (get-accounts))) | |
387 | ||
388 | (define (username->account username) | |
389 | "Return the first account associated with USERNAME, else #f. | |
390 | USERNAME can be either the account 40 characters public key fingerprint or a | |
391 | registered username." | |
392 | (find (lambda (account) | |
393 | (member username | |
394 | (list (assoc-ref account "Account.username") | |
395 | (assoc-ref account "Account.registeredName")))) | |
396 | (get-accounts))) | |
397 | ||
398 | (define (add-account archive) | |
399 | "Import the Jami account ARCHIVE and return its account ID. The archive | |
400 | should *not* be encrypted with a password. Return the username associated | |
401 | with the account." | |
402 | (invalidate-username-to-id-cache!) | |
403 | (let ((reply (send-dbus/configuration-manager | |
404 | #:method "addAccount" | |
405 | #:arguments (list (string-append | |
406 | "dict:string:string:Account.archivePath," | |
407 | archive | |
408 | ",Account.type,RING"))))) | |
409 | ;; The account information takes some time to be populated. | |
410 | (let ((id (deserialize-item (parse-dbus-reply reply)))) | |
411 | (with-retries 20 1 | |
412 | (let ((username (id->username id))) | |
413 | (if (string-null? username) | |
414 | #f | |
415 | username)))))) | |
416 | ||
417 | (define (remove-account username) | |
418 | "Delete the Jami account associated with USERNAME, the account 40 characters | |
419 | fingerprint or a registered username." | |
420 | (let ((id (username->id username))) | |
421 | (send-dbus/configuration-manager | |
422 | #:method "removeAccount" | |
423 | #:arguments (list (string-append "string:" id)))) | |
424 | (invalidate-username-to-id-cache!)) | |
425 | ||
426 | (define* (username->contacts username) | |
427 | "Return the contacts associated with the account of USERNAME as two values; | |
428 | the first one being the regular contacts and the second one the banned | |
429 | contacts. USERNAME can be either the account 40 characters public key | |
430 | fingerprint or a registered username. The contacts returned are represented | |
431 | using their 40 characters fingerprint." | |
432 | (let* ((id (username->id username)) | |
433 | (reply (send-dbus/configuration-manager | |
434 | #:method "getContacts" | |
435 | #:arguments (list (string-append "string:" id)))) | |
436 | (all-contacts (parse-contacts reply)) | |
437 | (banned? (lambda (contact) | |
438 | (and=> (assoc-ref contact "banned") | |
439 | (cut string=? "true" <>)))) | |
440 | (banned (filter banned? all-contacts)) | |
441 | (not-banned (filter (negate banned?) all-contacts)) | |
442 | (fingerprint (cut assoc-ref <> "id"))) | |
443 | (values (map fingerprint not-banned) | |
444 | (map fingerprint banned)))) | |
445 | ||
446 | (define* (remove-contact contact username #:key ban?) | |
447 | "Remove CONTACT, the 40 characters public key fingerprint of a contact, from | |
448 | the account associated with USERNAME (either a fingerprint or a registered | |
449 | username). When BAN? is true, also mark the contact as banned." | |
450 | (validate-fingerprint contact) | |
451 | (let ((id (username->id username))) | |
452 | (send-dbus/configuration-manager | |
453 | #:method "removeContact" | |
454 | #:arguments (list (string-append "string:" id) | |
455 | (string-append "string:" contact) | |
456 | (serialize-boolean ban?))))) | |
457 | ||
458 | (define (add-contact contact username) | |
459 | "Add CONTACT, the 40 characters public key fingerprint of a contact, to the | |
460 | account of USERNAME (either a fingerprint or a registered username)." | |
461 | (validate-fingerprint contact) | |
462 | (let ((id (username->id username))) | |
463 | (send-dbus/configuration-manager | |
464 | #:method "addContact" | |
465 | #:arguments (list (string-append "string:" id) | |
466 | (string-append "string:" contact))))) | |
467 | ||
468 | (define* (set-account-details details username #:key timeout) | |
469 | "Set DETAILS, an alist containing the key value pairs to set for the account | |
470 | of USERNAME, a registered username or account fingerprint. The value of the | |
471 | parameters not provided are unchanged. TIMEOUT is a value in milliseconds to | |
472 | pass to the `send-dbus/configuration-manager' procedure." | |
473 | (let* ((id (username->id username)) | |
474 | (current-details (id->account-details id)) | |
475 | (updated-details (map (match-lambda | |
476 | ((key . value) | |
477 | (or (and=> (assoc-ref details key) | |
478 | (cut cons key <>)) | |
479 | (cons key value)))) | |
480 | current-details)) | |
481 | ;; dbus-send does not permit sending null strings (it throws a | |
482 | ;; "malformed dictionary" error). Luckily they seem to have the | |
483 | ;; semantic of "default account value" in Jami; so simply drop them. | |
484 | (updated-details* (remove (match-lambda | |
485 | ((_ . value) | |
486 | (string-null? value))) | |
487 | updated-details))) | |
488 | (send-dbus/configuration-manager | |
489 | #:timeout timeout | |
490 | #:method "setAccountDetails" | |
491 | #:arguments | |
492 | (list (string-append "string:" id) | |
493 | (string-append "dict:string:string:" | |
494 | (string-join (alist->list updated-details*) | |
495 | ",")))))) | |
496 | ||
497 | (define (set-all-moderators enabled? username) | |
498 | "Set the 'AllModerators' property to enabled? for the account of USERNAME, a | |
499 | registered username or account fingerprint." | |
500 | (let ((id (username->id username))) | |
501 | (send-dbus/configuration-manager | |
502 | #:method "setAllModerators" | |
503 | #:arguments | |
504 | (list (string-append "string:" id) | |
505 | (serialize-boolean enabled?))))) | |
506 | ||
507 | (define (username->all-moderators? username) | |
508 | "Return the 'AllModerators' property for the account of USERNAME, a | |
509 | registered username or account fingerprint." | |
510 | (let* ((id (username->id username)) | |
511 | (reply (send-dbus/configuration-manager | |
512 | #:method "isAllModerators" | |
513 | #:arguments | |
514 | (list (string-append "string:" id))))) | |
515 | (deserialize-item (parse-dbus-reply reply)))) | |
516 | ||
517 | (define (username->moderators username) | |
518 | "Return the moderators for the account of USERNAME, a registered username or | |
519 | account fingerprint." | |
520 | (let* ((id (username->id username)) | |
521 | (reply (send-dbus/configuration-manager | |
522 | #:method "getDefaultModerators" | |
523 | #:arguments | |
524 | (list (string-append "string:" id))))) | |
525 | (array->list (parse-dbus-reply reply)))) | |
526 | ||
527 | (define (set-moderator contact enabled? username) | |
528 | "Set the moderator flag to ENABLED? for CONTACT, the 40 characters public | |
529 | key fingerprint of a contact for the account of USERNAME, a registered | |
530 | username or account fingerprint." | |
531 | (validate-fingerprint contact) | |
532 | (let* ((id (username->id username))) | |
533 | (send-dbus/configuration-manager #:method "setDefaultModerator" | |
534 | #:arguments | |
535 | (list (string-append "string:" id) | |
536 | (string-append "string:" contact) | |
537 | (serialize-boolean enabled?))))) | |
538 | ||
539 | (define (disable-account username) | |
540 | "Disable the account known by USERNAME, a registered username or account | |
541 | fingerprint." | |
542 | (set-account-details '(("Account.enable" . "false")) username | |
543 | ;; Waiting for the reply on this command takes a very | |
544 | ;; long time that trips the default D-Bus timeout value | |
545 | ;; (25 s), for some reason. | |
546 | #:timeout 60000)) | |
547 | ||
548 | (define (enable-account username) | |
549 | "Enable the account known by USERNAME, a registered username or account | |
550 | fingerprint." | |
551 | (set-account-details '(("Account.enable" . "true")) username)) | |
552 | ||
553 | \f | |
554 | ;;; | |
555 | ;;; Presentation procedures. | |
556 | ;;; | |
557 | ||
558 | (define (.->_ text) | |
559 | "Map each period character to underscore characters." | |
560 | (string-map (match-lambda | |
561 | (#\. #\_) | |
562 | (c c)) | |
563 | text)) | |
564 | ||
565 | (define (account-details->recutil account-details) | |
566 | "Serialize the account-details alist into a recutil string. Period | |
567 | characters in the keys are normalized to underscore to meet Recutils' format | |
568 | requirements." | |
569 | (define (pair->recutil-property pair) | |
570 | (match pair | |
571 | ((key . value) | |
572 | (string-append (.->_ key) ": " value)))) | |
573 | ||
574 | (define sorted-account-details | |
575 | ;; Have the account username, display name and alias appear first, for | |
576 | ;; convenience. | |
577 | (let ((first-items '("Account.username" | |
578 | "Account.displayName" | |
579 | "Account.alias"))) | |
580 | (append (map (cut assoc <> account-details) first-items) | |
581 | (fold alist-delete account-details first-items)))) | |
582 | ||
583 | (string-join (map pair->recutil-property sorted-account-details) "\n")) | |
584 | ||
585 | ;; Local Variables: | |
586 | ;; eval: (put 'with-retries 'scheme-indent-function 2) | |
587 | ;; End: |