projects/guix·blob python-team · refs

213 lines · 8.6 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 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 #:ensure #f)
68 (module-ref (resolve-interface '(fibers)) 'sleep)
69 (begin
70 (format #t "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
79return #f, else raise an error. A delay of DELAY seconds is inserted before
80each 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 (quote (begin body ...)) args))))))
95
96
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
108session, e.g. \"unix:path=/var/run/dbus/system_bus_socket\", the default value
109if ADDRESS is not provided and DBUS_SESSION_BUS_ADDRESS is not set. Return
110the 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
125READ-RETRIES replies are read until a matching reply is found, else an error
126is raised. MESSAGE is to be constructed with `make-d-bus-message'. When the
127body contains a single element, it is returned directly, else the body
128elements 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.
177The currently active D-Bus CONNECTION is used unless explicitly provided.
178Method arguments may be provided via ARGUMENTS sent as the message body.
179TIMEOUT limit the maximum time to allow for the reply. Return the body of the
180reply."
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
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: