[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master a418b0a 1/2: Extend dbus.el by error messages, and :write access
|
From: |
Michael Albinus |
|
Subject: |
master a418b0a 1/2: Extend dbus.el by error messages, and :write access type |
|
Date: |
Fri, 4 Sep 2020 09:09:32 -0400 (EDT) |
branch: master
commit a418b0a92090624e2c7beea3681f0a179ade837a
Author: Michael Albinus <michael.albinus@gmx.de>
Commit: Michael Albinus <michael.albinus@gmx.de>
Extend dbus.el by error messages, and :write access type
* doc/misc/dbus.texi (Receiving Method Calls): Describe how to
produce D-Bus error messages.
(Receiving Method Calls): Support :write access type.
* lisp/net/dbus.el (dbus-error-dbus, dbus-error-failed)
(dbus-error-access-denied, dbus-error-invalid-args)
(dbus-error-property-read-only): New defconsts.
(dbus-method-error-internal): Add arg ERROR-NAME.
(dbus-register-method): Adapt docstring.
(dbus-handle-event): Handle error messages returned from the handler.
(dbus-get-this-registered-property)
(dbus-get-other-registered-property): New defuns.
(dbus-register-property): Support :write access type.
(dbus-property-handler): Submit proper D-Bus error messages.
Handle several paths at the same interface.
* src/dbusbind.c (Fdbus_message_internal): Improve handling of
DBUS_MESSAGE_TYPE_ERROR.
---
doc/misc/dbus.texi | 52 ++++++++----
lisp/net/dbus.el | 230 ++++++++++++++++++++++++++++++++++-------------------
src/dbusbind.c | 18 ++++-
3 files changed, 202 insertions(+), 98 deletions(-)
diff --git a/doc/misc/dbus.texi b/doc/misc/dbus.texi
index 167d2bd..c16b7aa 100644
--- a/doc/misc/dbus.texi
+++ b/doc/misc/dbus.texi
@@ -1462,7 +1462,15 @@ cons cell, @var{handler} can return this object
directly, instead of
returning a list containing the object.
If @var{handler} returns a reply message with an empty argument list,
-@var{handler} must return the symbol @code{:ignore}.
+@var{handler} must return the symbol @code{:ignore} in order
+to distinguish it from @code{nil} (the boolean false).
+
+If @var{handler} detects an error, it shall return the list
+@code{(:error @var{ERROR-NAME} @var{ERROR-MESSAGE)}}.
+@var{ERROR-NAME} is a namespaced string which characterizes the error
+type, and @var{ERROR-MESSAGE} is a free text string. Alternatively,
+any Emacs signal @code{dbus-error} in @var{handler} raises a D-Bus
+error message with the error name @samp{org.freedesktop.DBus.Error.Failed}.
When @var{dont-register-service} is non-@code{nil}, the known name
@var{service} is not registered. This means that other D-Bus clients
@@ -1512,17 +1520,20 @@ could use the command line tool @code{dbus-send} in a
shell:
boolean true
@end example
-You can indicate an error by raising the Emacs signal
-@code{dbus-error}. The handler above could be changed like this:
+You can indicate an error by returning an @code{:error} list reply, or
+by raising the Emacs signal @code{dbus-error}. The handler above
+could be changed like this:
@lisp
(defun my-dbus-method-handler (&rest args)
- (unless (and (= (length args) 1) (stringp (car args)))
- (signal 'dbus-error (list (format "Wrong argument list: %S" args))))
- (condition-case err
- (find-file (car args))
- (error (signal 'dbus-error (cdr err))))
- t)
+ (if (not (and (= (length args) 1) (stringp (car args))))
+ (list :error
+ "org.freedesktop.TextEditor.Error.InvalidArgs"
+ (format "Wrong argument list: %S" args))
+ (condition-case err
+ (find-file (car args))
+ (error (signal 'dbus-error (cdr err))))
+ t))
@end lisp
The test then runs
@@ -1534,9 +1545,20 @@ The test then runs
"org.freedesktop.TextEditor.OpenFile" \
string:"/etc/hosts" string:"/etc/passwd"
-@print{} Error org.freedesktop.DBus.Error.Failed:
+@print{} Error org.freedesktop.TextEditor.Error.InvalidArgs:
Wrong argument list: ("/etc/hosts" "/etc/passwd")
@end example
+
+@example
+# dbus-send --session --print-reply \
+ --dest="org.freedesktop.TextEditor" \
+ "/org/freedesktop/TextEditor" \
+ "org.freedesktop.TextEditor.OpenFile" \
+ string:"/etc/crypttab"
+
+@print{} Error org.freedesktop.DBus.Error.Failed:
+ D-Bus error: "File is not readable", "/etc/crypttab"
+@end example
@end defun
@defun dbus-register-property bus service path interface property access value
&optional emits-signal dont-register-service
@@ -1556,14 +1578,16 @@ discussion of @var{dont-register-service} below).
@var{property} is the name of the property of @var{interface}.
@var{access} indicates, whether the property can be changed by other
-services via D-Bus. It must be either the symbol @code{:read} or
-@code{:readwrite}. @var{value} is the initial value of the property,
-it can be of any valid type (@xref{dbus-call-method}, for details).
+services via D-Bus. It must be either the symbol @code{:read},
+@code{:write} or @code{:readwrite}. @var{value} is the initial value
+of the property, it can be of any valid type (@xref{dbus-call-method},
+for details).
If @var{property} already exists on @var{path}, it will be
overwritten. For properties with access type @code{:read} this is the
only way to change their values. Properties with access type
-@code{:readwrite} can be changed by @code{dbus-set-property}.
+@code{:write} or @code{:readwrite} can be changed by
+@code{dbus-set-property}.
The interface @samp{org.freedesktop.DBus.Properties} is added to
@var{path}, including a default handler for the @samp{Get},
diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el
index 971d3e7..639b766 100644
--- a/lisp/net/dbus.el
+++ b/lisp/net/dbus.el
@@ -53,6 +53,8 @@
(require 'xml)
+;;; D-Bus constants.
+
(defconst dbus-service-dbus "org.freedesktop.DBus"
"The bus name used to talk to the bus itself.")
@@ -62,7 +64,8 @@
(defconst dbus-path-local (concat dbus-path-dbus "/Local")
"The object path used in local/in-process-generated messages.")
-;; Default D-Bus interfaces.
+
+;;; Default D-Bus interfaces.
(defconst dbus-interface-dbus "org.freedesktop.DBus"
"The interface exported by the service `dbus-service-dbus'.")
@@ -145,7 +148,28 @@ See URL
`https://dbus.freedesktop.org/doc/dbus-specification.html#standard-inter
;; </signal>
;; </interface>
-;; Emacs defaults.
+
+;;; Default D-Bus errors.
+
+(defconst dbus-error-dbus "org.freedesktop.DBus.Error"
+ "The namespace for default error names.
+See /usr/include/dbus-1.0/dbus/dbus-protocol.h.")
+
+(defconst dbus-error-failed (concat dbus-error-dbus ".Failed")
+ "A generic error; \"something went wrong\" - see the error message for
more.")
+
+(defconst dbus-error-access-denied (concat dbus-error-dbus ".AccessDenied")
+ "Security restrictions don't allow doing what you're trying to do.")
+
+(defconst dbus-error-invalid-args (concat dbus-error-dbus ".InvalidArgs")
+ "Invalid arguments passed to a method call.")
+
+(defconst dbus-error-property-read-only
+ (concat dbus-error-dbus ".PropertyReadOnly")
+ "Property you tried to set is read-only.")
+
+
+;;; Emacs defaults.
(defconst dbus-service-emacs "org.gnu.Emacs"
"The well known service name of Emacs.")
@@ -157,7 +181,8 @@ shall be subdirectories of this path.")
(defconst dbus-interface-emacs "org.gnu.Emacs"
"The interface namespace used by Emacs.")
-;; D-Bus constants.
+
+;;; Basic D-Bus message functions.
(defmacro dbus-ignore-errors (&rest body)
"Execute BODY; signal D-Bus error when `dbus-debug' is non-nil.
@@ -172,9 +197,6 @@ Otherwise, return result of last form in BODY, or all other
errors."
Every function must accept two arguments, the event and the error variable
caught in `condition-case' by `dbus-error'.")
-
-;;; Basic D-Bus message functions.
-
(defvar dbus-return-values-table (make-hash-table :test #'equal)
"Hash table for temporarily storing arguments of reply messages.
A key in this hash table is a list (:serial BUS SERIAL), like in
@@ -463,8 +485,9 @@ This is an internal function, it shall not be used outside
dbus.el."
(apply #'dbus-message-internal dbus-message-type-method-return
bus service serial args))
-(defun dbus-method-error-internal (bus service serial &rest args)
+(defun dbus-method-error-internal (bus service serial error-name &rest args)
"Return error message for message SERIAL on the D-Bus BUS.
+ERROR-NAME must belong to the \"org.freedesktop.DBus.Error\" namespace.
This is an internal function, it shall not be used outside dbus.el."
(or (featurep 'dbusbind)
@@ -477,7 +500,7 @@ This is an internal function, it shall not be used outside
dbus.el."
(signal 'wrong-type-argument (list 'natnump serial)))
(apply #'dbus-message-internal dbus-message-type-error
- bus service serial args))
+ bus service serial error-name args))
;;; Hash table of registered functions.
@@ -587,7 +610,7 @@ queue of this service."
(maphash
(lambda (key value)
- (unless (equal :serial (car key))
+ (unless (eq :serial (car key))
(dolist (elt value)
(ignore-errors
(when (and (equal bus (cadr key)) (string-equal service (cadr elt)))
@@ -775,10 +798,18 @@ discussion of DONT-REGISTER-SERVICE below). INTERFACE is
the
interface offered by SERVICE. It must provide METHOD.
HANDLER is a Lisp function to be called when a method call is
-received. It must accept the input arguments of METHOD. The return
-value of HANDLER is used for composing the returning D-Bus message.
-If HANDLER returns a reply message with an empty argument list,
-HANDLER must return the symbol `:ignore'.
+received. It must accept the input arguments of METHOD. The
+return value of HANDLER is used for composing the returning D-Bus
+message. If HANDLER returns a reply message with an empty
+argument list, HANDLER must return the symbol `:ignore' in order
+to distinguish it from `nil' (the boolean false).
+
+If HANDLER detects an error, it shall return the list `(:error
+ERROR-NAME ERROR-MESSAGE)'. ERROR-NAME is a namespaced string
+which characterizes the error type, and ERROR-MESSAGE is a free
+text string. Alternatively, any Emacs signal `dbus-error' in
+HANDLER raises a D-Bus error message with the error name
+\"org.freedesktop.DBus.Error.Failed\".
When DONT-REGISTER-SERVICE is non-nil, the known name SERVICE is not
registered. This means that other D-Bus clients have no way of
@@ -996,22 +1027,26 @@ If the HANDLER returns a `dbus-error', it is propagated
as return message."
(signal 'dbus-error (nthcdr 9 event)))
;; Apply the handler.
(setq result (apply (nth 8 event) (nthcdr 9 event)))
- ;; Return a message when it is a message call.
+ ;; Return an (error) message when it is a message call.
(when (= dbus-message-type-method-call (nth 2 event))
(dbus-ignore-errors
- (if (eq result :ignore)
- (dbus-method-return-internal
- (nth 1 event) (nth 4 event) (nth 3 event))
- (apply #'dbus-method-return-internal
- (nth 1 event) (nth 4 event) (nth 3 event)
- (if (consp result) result (list result)))))))
+ (if (eq (car-safe result) :error)
+ (apply #'dbus-method-error-internal
+ (nth 1 event) (nth 4 event) (nth 3 event) (cdr result))
+ (if (eq result :ignore)
+ (dbus-method-return-internal
+ (nth 1 event) (nth 4 event) (nth 3 event))
+ (apply #'dbus-method-return-internal
+ (nth 1 event) (nth 4 event) (nth 3 event)
+ (if (consp result) result (list result))))))))
;; Error handling.
(dbus-error
;; Return an error message when it is a message call.
(when (= dbus-message-type-method-call (nth 2 event))
(dbus-ignore-errors
(dbus-method-error-internal
- (nth 1 event) (nth 4 event) (nth 3 event) (cadr err))))
+ (nth 1 event) (nth 4 event) (nth 3 event) dbus-error-failed
+ (error-message-string err))))
;; Propagate D-Bus error messages.
(run-hook-with-args 'dbus-event-error-functions event err)
(when dbus-debug
@@ -1420,6 +1455,26 @@ nil is returned."
(dbus-call-method bus service path dbus-interface-properties
"GetAll" :timeout 500 interface))))
+(defun dbus-get-this-registered-property (bus _service path interface property)
+ "Return PROPERTY entry of `dbus-registered-objects-table'.
+Filter out not matching PATH."
+ ;; Remove entries not belonging to this case.
+ (seq-remove
+ (lambda (item)
+ (not (string-equal path (nth 2 item))))
+ (gethash (list :property bus interface property)
+ dbus-registered-objects-table)))
+
+(defun dbus-get-other-registered-property (bus _service path interface
property)
+ "Return PROPERTY entry of `dbus-registered-objects-table'.
+Filter out matching PATH."
+ ;; Remove matching entries.
+ (seq-remove
+ (lambda (item)
+ (string-equal path (nth 2 item)))
+ (gethash (list :property bus interface property)
+ dbus-registered-objects-table)))
+
(defun dbus-register-property
(bus service path interface property access value
&optional emits-signal dont-register-service)
@@ -1436,14 +1491,14 @@ discussion of DONT-REGISTER-SERVICE below). INTERFACE
is the
name of the interface used at PATH, PROPERTY is the name of the
property of INTERFACE. ACCESS indicates, whether the property
can be changed by other services via D-Bus. It must be either
-the symbol `:read' or `:readwrite'. VALUE is the initial value
-of the property, it can be of any valid type (see
+the symbol `:read', `:write' or `:readwrite'. VALUE is the
+initial value of the property, it can be of any valid type (see
`dbus-call-method' for details).
If PROPERTY already exists on PATH, it will be overwritten. For
properties with access type `:read' this is the only way to
-change their values. Properties with access type `:readwrite'
-can be changed by `dbus-set-property'.
+change their values. Properties with access type `:write' or
+`:readwrite' can be changed by `dbus-set-property'.
The interface \"org.freedesktop.DBus.Properties\" is added to
PATH, including a default handler for the \"Get\", \"GetAll\" and
@@ -1457,7 +1512,7 @@ of noticing the newly registered property. When
interfaces are
constructed incrementally by adding single methods or properties
at a time, DONT-REGISTER-SERVICE can be used to prevent other
clients from discovering the still incomplete interface."
- (unless (member access '(:read :readwrite))
+ (unless (member access '(:read :write :readwrite))
(signal 'wrong-type-argument (list "Access type invalid" access)))
;; Add handlers for the three property-related methods.
@@ -1479,24 +1534,26 @@ clients from discovering the still incomplete
interface."
(when emits-signal
(dbus-send-signal
bus service path dbus-interface-properties "PropertiesChanged"
- `((:dict-entry ,property (:variant ,value)))
- '(:array)))
+ (if (member access '(:read :readwrite))
+ `(:array (:dict-entry ,property (:variant ,value)))
+ '(:array: :signature "{sv}"))
+ (if (eq access :write)
+ `(:array ,property)
+ '(:array))))
;; Create a hash table entry. We use nil for the unique name,
;; because the property might be accessed from anybody.
- (let* ((key (list :property bus interface property))
- ;; Remove possible existing entry, because it must be overwritten.
- (val (seq-remove
- (lambda (item)
- (equal (butlast item) (list nil service path)))
- (gethash key dbus-registered-objects-table)))
- (entry
+ (let ((key (list :property bus interface property))
+ (val
+ (cons
(list
nil service path
(cons
(if emits-signal (list access :emits-signal) (list access))
- value))))
- (puthash key (cons entry val) dbus-registered-objects-table)
+ value))
+ (dbus-get-other-registered-property
+ bus service path interface property))))
+ (puthash key val dbus-registered-objects-table)
;; Return the object.
(list key (list service path))))
@@ -1513,61 +1570,70 @@ It will be registered for all objects created by
`dbus-register-property'."
(cond
;; "Get" returns a variant.
((string-equal method "Get")
- (let ((entry
- ;; Remove entries not belonging to this case.
- (seq-remove
- (lambda (item)
- (not (string-equal (nth 2 item) path)))
- (gethash (list :property bus interface property)
- dbus-registered-objects-table))))
-
- (when (string-equal path (nth 2 (car entry)))
- `((:variant ,(cdar (last (car entry))))))))
+ (let* ((entry (dbus-get-this-registered-property
+ bus service path interface property))
+ (object (car (last (car entry)))))
+ (cond
+ ((not (consp object))
+ `(:error ,dbus-error-invalid-args
+ ,(format-message
+ "No such property \"%s\" at path \"%s\"" property path)))
+ ((eq (car object) :write)
+ `(:error ,dbus-error-access-denied
+ ,(format-message
+ "Property \"%s\" at path \"%s\" is not readable" property path)))
+ ;; Return the result.
+ (t `((:variant ,(cdar (last (car entry)))))))))
;; "Set" expects a variant.
((string-equal method "Set")
(let* ((value (caar (cddr args)))
- (entry (gethash (list :property bus interface property)
- dbus-registered-objects-table))
- ;; The value of the hash table is a list; in case of
- ;; properties it contains just one element (UNAME SERVICE
- ;; PATH OBJECT). OBJECT is a cons cell of a list, which
- ;; contains a list of annotations (like :read,
- ;; :read-write, :emits-signal), and the value of the
- ;; property.
+ (entry (dbus-get-this-registered-property
+ bus service path interface property))
(object (car (last (car entry)))))
- (unless (consp object)
- (signal 'dbus-error
- (list "Property not registered at path" property path)))
- (unless (member :readwrite (car object))
- (signal 'dbus-error
- (list "Property not writable at path" property path)))
- (puthash (list :property bus interface property)
- (list (append (butlast (car entry))
- (list (cons (car object) value))))
- dbus-registered-objects-table)
- ;; Send the "PropertiesChanged" signal.
- (when (member :emits-signal (car object))
- (dbus-send-signal
- bus service path dbus-interface-properties "PropertiesChanged"
- `((:dict-entry ,property (:variant ,value)))
- '(:array)))
- ;; Return empty reply.
- :ignore))
+ (cond
+ ((not (consp object))
+ `(:error ,dbus-error-invalid-args
+ ,(format-message
+ "No such property \"%s\" at path \"%s\"" property path)))
+ ((eq (car object) :read)
+ `(:error ,dbus-error-property-read-only
+ ,(format-message
+ "Property \"%s\" at path \"%s\" is not writable" property path)))
+ (t (puthash (list :property bus interface property)
+ (cons (append (butlast (car entry))
+ (list (cons (car object) value)))
+ (dbus-get-other-registered-property
+ bus service path interface property))
+ dbus-registered-objects-table)
+ ;; Send the "PropertiesChanged" signal.
+ (when (member :emits-signal (car object))
+ (dbus-send-signal
+ bus service path dbus-interface-properties "PropertiesChanged"
+ (if (or (member :read (car object))
+ (member :readwrite (car object)))
+ `(:array (:dict-entry ,property (:variant ,value)))
+ '(:array: :signature "{sv}"))
+ (if (eq (car object) :write)
+ `(:array ,property)
+ '(:array))))
+ ;; Return empty reply.
+ :ignore))))
;; "GetAll" returns "a{sv}".
((string-equal method "GetAll")
(let (result)
(maphash
(lambda (key val)
- (when (and (equal (butlast key) (list :property bus interface))
- (string-equal path (nth 2 (car val)))
- (not (functionp (car (last (car val))))))
- (push
- (list :dict-entry
- (car (last key))
- (list :variant (cdar (last (car val)))))
- result)))
+ (dolist (item val)
+ (when (and (equal (butlast key) (list :property bus interface))
+ (string-equal path (nth 2 item))
+ (not (functionp (car (last item)))))
+ (push
+ (list :dict-entry
+ (car (last key))
+ (list :variant (cdar (last item))))
+ result))))
dbus-registered-objects-table)
;; Return the result, or an empty array.
(list :array (or result '(:signature "{sv}"))))))))
@@ -1775,5 +1841,7 @@ this connection to those buses."
;; * Implement org.freedesktop.DBus.ObjectManager.InterfacesAdded and
;; org.freedesktop.DBus.ObjectManager.InterfacesRemoved.
+;;
+;; * Run handlers in own threads.
;;; dbus.el ends here
diff --git a/src/dbusbind.c b/src/dbusbind.c
index f6a0879..4fce925 100644
--- a/src/dbusbind.c
+++ b/src/dbusbind.c
@@ -1261,6 +1261,7 @@ usage: (dbus-message-internal &rest REST) */)
Lisp_Object path = Qnil;
Lisp_Object interface = Qnil;
Lisp_Object member = Qnil;
+ Lisp_Object error_name = Qnil;
Lisp_Object result;
DBusConnection *connection;
DBusMessage *dmessage;
@@ -1298,7 +1299,9 @@ usage: (dbus-message-internal &rest REST) */)
else /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR */
{
serial = xd_extract_unsigned (args[3], TYPE_MAXIMUM (dbus_uint32_t));
- count = 4;
+ if (mtype == DBUS_MESSAGE_TYPE_ERROR)
+ error_name = args[4];
+ count = (mtype == DBUS_MESSAGE_TYPE_ERROR) ? 5 : 4;
}
/* Check parameters. */
@@ -1341,13 +1344,22 @@ usage: (dbus-message-internal &rest REST) */)
XD_OBJECT_TO_STRING (interface),
XD_OBJECT_TO_STRING (member));
break;
- default: /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR */
+ case DBUS_MESSAGE_TYPE_METHOD_RETURN:
ui_serial = serial;
XD_DEBUG_MESSAGE ("%s %s %s %u",
XD_MESSAGE_TYPE_TO_STRING (mtype),
XD_OBJECT_TO_STRING (bus),
XD_OBJECT_TO_STRING (service),
ui_serial);
+ break;
+ default: /* DBUS_MESSAGE_TYPE_ERROR */
+ ui_serial = serial;
+ XD_DEBUG_MESSAGE ("%s %s %s %u %s",
+ XD_MESSAGE_TYPE_TO_STRING (mtype),
+ XD_OBJECT_TO_STRING (bus),
+ XD_OBJECT_TO_STRING (service),
+ ui_serial,
+ XD_OBJECT_TO_STRING (error_name));
}
/* Retrieve bus address. */
@@ -1406,7 +1418,7 @@ usage: (dbus-message-internal &rest REST) */)
XD_SIGNAL1 (build_string ("Unable to create a return message"));
if ((mtype == DBUS_MESSAGE_TYPE_ERROR)
- && (!dbus_message_set_error_name (dmessage, DBUS_ERROR_FAILED)))
+ && (!dbus_message_set_error_name (dmessage, SSDATA (error_name))))
XD_SIGNAL1 (build_string ("Unable to create an error message"));
}