gnu/build/jami-service.scm

   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: