From 5223cc3afc97bac14e1757f6324539d3fadf658f Mon Sep 17 00:00:00 2001
From: Daniel Nagy <danielnagy@posteo.de>
Date: Fri, 29 Apr 2022 17:58:09 +0200
Subject: [PATCH] Implement Properties

This brings initial support for properties. For each registered
dbus-object we preimplement the `org.freedesktop.DBus.Properties` interface.

With this commit, only the `Get` method is supported. The `GetAll`
method is lacking and signals for property changes are not emitted as well.

More info on DBus properties:

https://dbus.freedesktop.org/doc/dbus-api-design.html#interface-properties
---
 all.lisp              |  1 +
 examples/publish.lisp |  4 ++++
 publish.lisp          | 24 ++++++++++++++++++++++--
 3 files changed, 27 insertions(+), 2 deletions(-)

diff --git a/all.lisp b/all.lisp
index ecdd0a0..f1b3222 100644
--- a/all.lisp
+++ b/all.lisp
@@ -159,4 +159,5 @@
    #:define-dbus-object
    #:define-dbus-method
    #:define-dbus-signal-handler
+   #:define-dbus-property
    #:publish-objects))
diff --git a/examples/publish.lisp b/examples/publish.lisp
index d2efff6..73ce538 100644
--- a/examples/publish.lisp
+++ b/examples/publish.lisp
@@ -15,6 +15,10 @@
   (:interface "org.adeht.MyService")
   (concatenate 'string s1 s2))
 
+(define-dbus-property (my-service my-property)
+  (:interface "org.adeht.MyService")
+  "initial-property-value")
+
 (define-dbus-signal-handler (my-service on-signal) ((s :string))
   (:interface "org.adeht.MyService")
   (format t "Got signal with arg ~S~%" s))
diff --git a/publish.lisp b/publish.lisp
index 3c8e7a5..9ace692 100644
--- a/publish.lisp
+++ b/publish.lisp
@@ -15,6 +15,7 @@
    #:define-dbus-object
    #:define-dbus-method
    #:define-dbus-signal-handler
+   #:define-dbus-property
    #:publish-objects))
 
 (in-package #:dbus/publish)
@@ -30,7 +31,8 @@
   ((name :initarg :name :reader dbus-object-name)
    (path :initarg :path :accessor dbus-object-path)
    (method-handlers :initform (make-hash-table :test 'equal) :reader dbus-object-method-handlers)
-   (signal-handlers :initform (make-hash-table :test 'equal) :reader dbus-object-signal-handlers)))
+   (signal-handlers :initform (make-hash-table :test 'equal) :reader dbus-object-signal-handlers)
+   (properties      :initform (make-hash-table :test 'equal) :reader dbus-object-properties)))
 
 (defgeneric dbus-object-handler-lookup-table (message object))
 
@@ -81,7 +83,18 @@
     (dolist (option options)
       (when (and (consp option) (eq (car option) :path))
         (setf path (cadr option))))
-    `(register-dbus-object ',name ,path)))
+    `(prog1
+       (register-dbus-object ',name ,path)
+       (define-dbus-method (,name get) ((interface :string) (property :string)) (:variant)
+         (:interface "org.freedesktop.DBus.Properties")
+         (let* ((obj (find-dbus-object ',name))
+                (value (gethash (cons interface property) (dbus-object-properties obj)))
+                (type-to-dbus (typecase value
+                                ((or null boolean) "b")
+                                (string "s")
+                                (integer "t")
+                                (float "d"))))
+           (list type-to-dbus value))))))
 
 ;;; Define handlers
 
@@ -192,6 +205,13 @@ sans dashes."
                                    (lambda (,@parameter-names)
                                      ,@body))))
 
+(defmacro define-dbus-property ((object-name property-name) &body body)
+  `(setf
+     (gethash
+       ',(cons (getf (car body) :interface) (stringify-lisp-name (symbol-name property-name)))
+       (dbus-object-properties (find-dbus-object ',object-name)))
+     ',(cadr body)))
+
 ;;; Publishing objects
 
 (defgeneric publish-objects (connection &optional object-names))