diff options
Diffstat (limited to 'gnu/build')
| -rw-r--r-- | gnu/build/jami-service.scm | 587 | ||||
| -rw-r--r-- | gnu/build/shepherd.scm | 14 |
2 files changed, 593 insertions, 8 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: diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm index d7b858dea4..778e3fc627 100644 --- a/gnu/build/shepherd.scm +++ b/gnu/build/shepherd.scm @@ -24,6 +24,12 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) + ;; XXX: Lazy-bind the Shepherd to avoid a compile-time dependency. + #:autoload (shepherd service) (fork+exec-command + read-pid-file + exec-command + %precious-signals) + #:autoload (shepherd system) (unblock-signals) #:export (make-forkexec-constructor/container fork+exec-command/container)) @@ -92,14 +98,6 @@ (file-exists? (file-system-mapping-source mapping))) mappings))))) -;; XXX: Lazy-bind the Shepherd to avoid a compile-time dependency. -(module-autoload! (current-module) - '(shepherd service) - '(fork+exec-command read-pid-file exec-command - %precious-signals)) -(module-autoload! (current-module) - '(shepherd system) '(unblock-signals)) - (define* (read-pid-file/container pid pid-file #:key (max-delay 5)) "Read PID-FILE in the container namespaces of PID, which exists in a separate mount and PID name space. Return the \"outer\" PID. " |