gnu/build/dbus-service.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2021, 2022 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 procedures to interact with D-Bus via the 'dbus-send'
  22 ;;; command line utility.  Before using any public procedure
  23 ;;;
  24 ;;; Code:
  25
  26 (define-module (gnu build dbus-service)
  27   #:use-module (ice-9 match)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (srfi srfi-19)
  30   #:use-module (srfi srfi-26)
  31   #:autoload (d-bus protocol connections) (d-bus-conn?
  32                                            d-bus-conn-flush
  33                                            d-bus-connect
  34                                            d-bus-disconnect
  35                                            d-bus-session-bus-address
  36                                            d-bus-system-bus-address)
  37   #:autoload (d-bus protocol messages) (MESSAGE_TYPE_METHOD_CALL
  38                                         d-bus-headers-ref
  39                                         d-bus-message-body
  40                                         d-bus-message-headers
  41                                         d-bus-read-message
  42                                         d-bus-write-message
  43                                         header-PATH
  44                                         header-DESTINATION
  45                                         header-INTERFACE
  46                                         header-MEMBER
  47                                         header-SIGNATURE
  48                                         make-d-bus-message)
  49   #:export (%dbus-query-timeout
  50
  51             initialize-dbus-connection!
  52             %current-dbus-connection
  53             send-dbus
  54             call-dbus-method
  55
  56             dbus-available-services
  57             dbus-service-available?
  58
  59             with-retries))
  60
  61 (define %dbus-query-timeout 2)          ;in seconds
  62
  63 ;;; Use Fibers' sleep to enable cooperative scheduling in Shepherd >= 0.9.0,
  64 ;;; which is required at least for the Jami service.
  65 (define sleep*
  66   (lambda ()                            ;delay execution
  67     (if (resolve-module '(fibers) #f)
  68         (module-ref (resolve-interface '(fibers)) 'sleep)
  69         (begin
  70           (format #f "fibers not available -- blocking 'sleep' in use")
  71           sleep))))
  72
  73 ;;;
  74 ;;; Utilities.
  75 ;;;
  76
  77 (define-syntax-rule (with-retries n delay body ...)
  78   "Retry the code in BODY up to N times until it doesn't raise an exception nor
  79 return #f, else raise an error.  A delay of DELAY seconds is inserted before
  80 each retry."
  81   (let loop ((attempts 0))
  82     (catch #t
  83       (lambda ()
  84         (let ((result (begin body ...)))
  85           (if (not result)
  86               (error "failed attempt" attempts)
  87               result)))
  88       (lambda args
  89         (if (< attempts n)
  90             (begin
  91               ((sleep*) delay)            ;else wait and retry
  92               (loop (+ 1 attempts)))
  93             (error "maximum number of retry attempts reached"
  94                    body ... args))))))
  95
  96 \f
  97 ;;;
  98 ;;; Low level wrappers above AC/D-Bus.
  99 ;;;
 100
 101 ;; The active D-Bus connection (a parameter) used by the other procedures.
 102 (define %current-dbus-connection (make-parameter #f))
 103
 104 (define* (initialize-dbus-connection!
 105           #:key (address (or (d-bus-session-bus-address)
 106                              (d-bus-system-bus-address))))
 107   "Initialize the D-Bus connection.  ADDRESS should be the address of the D-Bus
 108 session, e.g. \"unix:path=/var/run/dbus/system_bus_socket\", the default value
 109 if ADDRESS is not provided and DBUS_SESSION_BUS_ADDRESS is not set.  Return
 110 the initialized D-Bus connection."
 111   ;; Clear current correction if already active.
 112   (when (d-bus-conn? (%current-dbus-connection))
 113     (d-bus-disconnect (%current-dbus-connection)))
 114
 115   (let ((connection (d-bus-connect address)))
 116     (%current-dbus-connection connection) ;update connection parameter
 117     (call-dbus-method "Hello"))           ;initial handshake
 118
 119   (%current-dbus-connection))
 120
 121 (define* (send-dbus message #:key
 122                     (connection (%current-dbus-connection))
 123                     timeout)
 124   "Send a D-Bus MESSAGE to CONNECTION and return the body of its reply.  Up to
 125 READ-RETRIES replies are read until a matching reply is found, else an error
 126 is raised.  MESSAGE is to be constructed with `make-d-bus-message'.  When the
 127 body contains a single element, it is returned directly, else the body
 128 elements are returned as a list.  TIMEOUT is a timeout value in seconds."
 129   (let ((serial     (d-bus-write-message connection message))
 130         (start-time (current-time time-monotonic))
 131         (timeout* (or timeout %dbus-query-timeout)))
 132     (d-bus-conn-flush connection)
 133     (let retry ()
 134       (when (> (time-second (time-difference (current-time time-monotonic)
 135                                              start-time))
 136                timeout*)
 137         (error 'dbus "fail to get reply in timeout" timeout*))
 138       (let* ((reply (d-bus-read-message connection))
 139              (reply-headers (d-bus-message-headers reply))
 140              (reply-serial (d-bus-headers-ref reply-headers 'REPLY_SERIAL))
 141              (error-name (d-bus-headers-ref reply-headers 'ERROR_NAME))
 142              (body (d-bus-message-body reply)))
 143         ;; Validate the reply matches the message.
 144         (when error-name
 145           (error 'dbus "method failed with error" error-name body))
 146         ;; Some replies do not include a serial header, such as the for the
 147         ;; org.freedesktop.DBus NameAcquired one.
 148         (if (and reply-serial (= serial reply-serial))
 149             (match body
 150               ((x x* ..1)               ;contains 2 ore more elements
 151                body)
 152               ((x)
 153                x)                       ;single element; return it directly
 154               (#f #f))
 155             (retry))))))
 156
 157 (define (argument->signature-type argument)
 158   "Infer the D-Bus signature type from ARGUMENT."
 159   ;; XXX: avoid ..1 when using vectors due to a bug (?) in (ice-9 match).
 160   (match argument
 161     ((? boolean?) "b")
 162     ((? string?) "s")
 163     (#((? string?) (? string?) ...) "as")
 164     (#(((? string?) . (? string?))
 165        ((? string?) . (? string?)) ...) "a{ss}")
 166     (_ (error 'dbus "no rule to infer type from argument" argument))))
 167
 168 (define* (call-dbus-method method
 169                            #:key
 170                            (path "/org/freedesktop/DBus")
 171                            (destination "org.freedesktop.DBus")
 172                            (interface "org.freedesktop.DBus")
 173                            (connection (%current-dbus-connection))
 174                            arguments
 175                            timeout)
 176   "Call the D-Bus method specified by METHOD, PATH, DESTINATION and INTERFACE.
 177 The currently active D-Bus CONNECTION is used unless explicitly provided.
 178 Method arguments may be provided via ARGUMENTS sent as the message body.
 179 TIMEOUT limit the maximum time to allow for the reply.  Return the body of the
 180 reply."
 181   (let ((message (make-d-bus-message
 182                   MESSAGE_TYPE_METHOD_CALL 0 #f '()
 183                   `#(,(header-PATH        path)
 184                      ,(header-DESTINATION destination)
 185                      ,(header-INTERFACE   interface)
 186                      ,(header-MEMBER      method)
 187                      ,@(if arguments
 188                            (list (header-SIGNATURE
 189                                   (string-join
 190                                    (map argument->signature-type arguments)
 191                                    "")))
 192                            '()))
 193                   arguments)))
 194     (send-dbus message #:connection connection #:timeout timeout)))
 195
 196 \f
 197 ;;;
 198 ;;; Higher-level, D-Bus procedures.
 199 ;;;
 200
 201 (define (dbus-available-services)
 202   "Return the list of available (acquired) D-Bus services."
 203   (let ((names (vector->list (call-dbus-method "ListNames"))))
 204     ;; Remove entries such as ":1.7".
 205     (remove (cut string-prefix? ":" <>) names)))
 206
 207 (define (dbus-service-available? service)
 208   "Predicate to check for the D-Bus SERVICE availability."
 209   (member service (dbus-available-services)))
 210
 211 ;; Local Variables:
 212 ;; eval: (put 'with-retries 'scheme-indent-function 2)
 213 ;; End: