aboutsummaryrefslogtreecommitdiff
generated by cgit
ed and DBUS_SESSION_BUS_ADDRESS is not set. Return the initialized D-Bus connection." ;; Clear current correction if already active. (when (d-bus-conn? (%current-dbus-connection)) (d-bus-disconnect (%current-dbus-connection))) (let ((connection (d-bus-connect address))) (%current-dbus-connection connection) ;update connection parameter (call-dbus-method "Hello")) ;initial handshake (%current-dbus-connection)) (define* (send-dbus message #:key (connection (%current-dbus-connection)) timeout) "Send a D-Bus MESSAGE to CONNECTION and return the body of its reply. Up to READ-RETRIES replies are read until a matching reply is found, else an error is raised. MESSAGE is to be constructed with `make-d-bus-message'. When the body contains a single element, it is returned directly, else the body elements are returned as a list. TIMEOUT is a timeout value in seconds." (let ((serial (d-bus-write-message connection message)) (start-time (current-time time-monotonic)) (timeout* (or timeout %dbus-query-timeout))) (d-bus-conn-flush connection) (let retry () (when (> (time-second (time-difference (current-time time-monotonic) start-time)) timeout*) (error 'dbus "fail to get reply in timeout" timeout*)) (let* ((reply (d-bus-read-message connection)) (reply-headers (d-bus-message-headers reply)) (reply-serial (d-bus-headers-ref reply-headers 'REPLY_SERIAL)) (error-name (d-bus-headers-ref reply-headers 'ERROR_NAME)) (body (d-bus-message-body reply))) ;; Validate the reply matches the message. (when error-name (error 'dbus "method failed with error" error-name body)) ;; Some replies do not include a serial header, such as the for the ;; org.freedesktop.DBus NameAcquired one. (if (and reply-serial (= serial reply-serial)) (match body ((x x* ..1) ;contains 2 ore more elements body) ((x) x) ;single element; return it directly (#f #f)) (retry)))))) (define (argument->signature-type argument) "Infer the D-Bus signature type from ARGUMENT." ;; XXX: avoid ..1 when using vectors due to a bug (?) in (ice-9 match). (match argument ((? boolean?) "b") ((? string?) "s") (#((? string?) (? string?) ...) "as") (#(((? string?) . (? string?)) ((? string?) . (? string?)) ...) "a{ss}") (_ (error 'dbus "no rule to infer type from argument" argument)))) (define* (call-dbus-method method #:key (path "/org/freedesktop/DBus") (destination "org.freedesktop.DBus") (interface "org.freedesktop.DBus") (connection (%current-dbus-connection)) arguments timeout) "Call the D-Bus method specified by METHOD, PATH, DESTINATION and INTERFACE. The currently active D-Bus CONNECTION is used unless explicitly provided. Method arguments may be provided via ARGUMENTS sent as the message body. TIMEOUT limit the maximum time to allow for the reply. Return the body of the reply." (let ((message (make-d-bus-message MESSAGE_TYPE_METHOD_CALL 0 #f '() `#(,(header-PATH path) ,(header-DESTINATION destination) ,(header-INTERFACE interface) ,(header-MEMBER method) ,@(if arguments (list (header-SIGNATURE (string-join (map argument->signature-type arguments) ""))) '())) arguments))) (send-dbus message #:connection connection #:timeout timeout))) ;;; ;;; Higher-level, D-Bus procedures. ;;; (define (dbus-available-services) "Return the list of available (acquired) D-Bus services." (let ((names (vector->list (call-dbus-method "ListNames")))) ;; Remove entries such as ":1.7". (remove (cut string-prefix? ":" <>) names))) (define (dbus-service-available? service) "Predicate to check for the D-Bus SERVICE availability." (member service (dbus-available-services))) ;; Local Variables: ;; eval: (put 'with-retries 'scheme-indent-function 2) ;; End: