X-Git-Url: https://git.rrq.au/?a=blobdiff_plain;f=lsp-dbus%2Flsp-dbus.lsp;h=98aa0279337987df3dccff9ec16d3c1771fec4ce;hb=121167c737403e2f49231fd5704aae86850b5b38;hp=e40c2eb2c02fb75f6df6b34fee5b42c6edea062e;hpb=1898ef96b70cb93c53a84e6a7536d0a3bceb35d6;p=rrq%2Flsp-utils.git

diff --git a/lsp-dbus/lsp-dbus.lsp b/lsp-dbus/lsp-dbus.lsp
index e40c2eb..98aa027 100644
--- a/lsp-dbus/lsp-dbus.lsp
+++ b/lsp-dbus/lsp-dbus.lsp
@@ -11,22 +11,16 @@
 ;;
 
 (unless (context? MAIN:FOOP) (load "foop.lsp"))
+(unless (context? MAIN:prog1) (load "misc.lsp"))
 (unless (context? MAIN:DbusConnection) (load "lsp-dbus-connection.lsp"))
 
 #################################################################
 (context 'MAIN:Dbus)
 
-; Include marshalling functions
-(load "lsp-dbus-marshal.lsp" MAIN:Dbus)
-
 ;; Declaring the FOOP object
 (FOOP path bus)
 
-
-(setf SYSTEM-BUS (MAIN:DbusConnection "/run/dbus/system_bus_socket"))
-(:initialize SYSTEM-BUS)
-
-;; "Constructor". Creates an adapter object for a given base path.
+;; "The FOOP Constructor". Creates an object for a given path.
 (define (Dbus:Dbus PATH (BUS 'SYSTEM-BUS))
   (list (context) PATH BUS))
 
@@ -34,12 +28,18 @@
 (define (bus-name)
   (join (find-all "([^/]+)" (%path) $1 0) "."))
 
-;; Return the DbusConnection connection adapter 
-(define (connection)
-  (eval (%bus)))
+;; Update the connection serial and return it
+(define (connection++)
+  (case (%bus)
+    (SYSTEM-BUS (:serial++ SYSTEM-BUS))
+    (true 0)))
+
+; Include marshalling functions and signal handling framework
+(load "lsp-dbus-marshal.lsp" (context))
+(load "lsp-dbus-events.lsp" (context))
 
 ;; ====================
-;; Dbus messages
+;; Dbus symbols
 
 (constant
  'PROTOCOL-VERSION '(1 1)
@@ -47,7 +47,7 @@
  'MESSAGE-FLAGS '(NO_REPLY_EXPECTED
                   NO_AUTO_START
                   ALLOW_INTERACTIVE_AUTHORIZATION)
- ;; Message headers: [code] (name type)
+ ;; Message headers: [code] => (name type)
  'MESSAGE-HEADERS '((INVALID )
                     (PATH "o")
                     (INTERFACE "s")
@@ -61,20 +61,21 @@
                     )
  )
 
-;; Determine the type code = index of teh type symbol in the
-;; MESSAGE-TYPES list.
+;; Map message type symbol to dbus type code (i.e. the list index)
 (define (message-type-code TYPE)
   (or (find TYPE MESSAGE-TYPES =) 0))
 
+;; Map flag symbol F to its dbus "bit code"
 (define (flag F)
   (if (find F MESSAGE-FLAGS) (pow 2 $it) 0))
 
-;; Combining header flag symbols into the flags code = bit-or of the
-;; 2^x values where x is the index for the flag symbol in the
-;; MESSAGE-FLAGS list.
+;; Return the dbus flags code from FLAGS; if it is a number thent tha
+;; is returned as is; if FLAGS is a list of message flag symbols then
+;; combine their codes by bit-OR. Anything else yields 0.
 (define (message-flags FLAGS)
   (if (number? FLAGS) FLAGS
-    (list? FLAGS) (apply | (map flag FLAGS))
+    (list? FLAGS)
+    (apply | (map flag FLAGS))
     0))
 
 ;; (message-header (NAME VALUE))
@@ -82,10 +83,19 @@
 ; its header code and associated value type. This gets translated into
 ; the marshalling data form of (code (type value))
 (define (message-header HDR)
-  (let ((CODE (find (list (HDR 0) '*) MESSAGE-HEADERS match) 0))
-    (list CODE (list (MESSAGE-HEADERS CODE 1) (HDR 1)))))
-
-;; Return a marshalled message
+  (when (list? HDR)
+    (if (find (list (HDR 0) '*) MESSAGE-HEADERS match)
+        (list $it (list (MESSAGE-HEADERS $it -1) (HDR 1))))))
+
+;; Join the excess string arguments N-byte alignment successively
+(define (pad-join N)
+  (let ((OUT ""))
+    (dolist (S (args))
+      (let ((PAD (dup "\000" (% (- N (% (length OUT) N)) N))))
+        (extend OUT PAD S)))
+    OUT))
+
+;; Return a marshalled message string appended by the marshalled body
 (define (message TYPE FLAGS HDRS BODY)
   (pad-join 8
             (pack-data "yyyyuua(yv)"
@@ -94,31 +104,124 @@
                              (message-flags FLAGS)
                              (PROTOCOL-VERSION 0) ; Major version code
                              (length BODY)
-                             (:serial++ (connection))
-                             (map message-header HDRS)))
-            BODY))
-
-(define (method-body ARGS)
-  "")
-
-;; Invoke a method on an object via dbus
-; (:invoke OBJ MEMBER INTERFACE FLAGS)
-(define (invoke MEMBER INTERFACE (FLAGS 0))
-  (or INTERFACE (setf INTERFACE (bus-name)))
-  (if (message 'METHOD_CALL FLAGS
-               (list (list 'PATH (%path))
-                     (list 'DESTINATION (bus-name))
-                     (list 'INTERFACE INTERFACE)
-                     (list 'MEMBER MEMBER))
-               (method-body (args)))
-      (begin
-        (let ((MSG $it) (BUFFER "") (RESULT "") (S (:%socket (connection))))
-          (net-send S MSG)
-          (while (net-select S "r" 1000)
-            (net-receive S BUFFER 8192)
-            (extend RESULT BUFFER))
-          BUFFER))
-    nil
-    ))
+                             (connection++)
+                             (clean null? (map message-header HDRS))))
+            BODY ))
+
+;; (:invoke OBJ METHOD ARGS FLAGS)
+; Perform a METHOD_CALL on the (self) object
+;; The given METHOD has format "INTERFACE.NAME(SIGNATURE)" with the
+;; "INTERFACE." bit optional. The function returns the list of headers
+;; of the reply message extended with reply value as a faked header
+;; named "".
+;;
+;; This function calls send-recv-message which also polls for signals
+;; until a reply is given, but any such signals are stocked up as
+;; pending for later processing on demand.
+(define (invoke METHOD ARGS (FLAGS 0))
+  (when (regex "((.+)\\.)?([^(]+)\\((.*)\\)$" METHOD 0)
+    (let ((INTERFACE $2) (MEMBER $3) (SIGNATURE $4))
+      ;;(println (list 'invoke (bus-name) INTERFACE MEMBER SIGNATURE))
+      (if (message 'METHOD_CALL FLAGS
+                   (list nil ; (if SELF-NAME (list 'SENDER SELF-NAME))
+                         (list 'DESTINATION (bus-name))
+                         (list 'PATH (%path))
+                         (if (empty? INTERFACE) nil
+                           (list 'INTERFACE INTERFACE))
+                         (list 'MEMBER MEMBER)
+                         (if (empty? SIGNATURE) nil
+                           (list 'SIGNATURE SIGNATURE))
+                         )
+                   (if (empty? SIGNATURE) ""
+                     (pack-data SIGNATURE ARGS)))
+          (send-recv-message $it)
+        nil
+        ))))
+
+;; Context variables and framework registration
+
+(setf
+ SYSTEM-BUS (MAIN:DbusConnection "/run/dbus/system_bus_socket")
+ APPID (:initialize SYSTEM-BUS)
+ ROOT (Dbus "/org/freedesktop/DBus")
+ APPNAME (if (lookup "" (:invoke ROOT "org.freedesktop.DBus.Hello()"))
+               ($it 0))
+ )
+
+;; Installation of some framework notification handlers
+
+;; Helper method to notify
+(define (signal-trace ARGS)
+  (die nil "** Got:" KEY ARGS ))
+
+(:handler ROOT "org.freedesktop.DBus.NameAcquired(s)" signal-trace)
+(:handler ROOT "org.freedesktop.DBus.NameLost(s)" signal-trace)
+(:handler ROOT "org.freedesktop.DBus.NameOwnerChanged(sss)" signal-trace)
+
+ ; Process notifications that came with the registration handshake
+(process-all-pending)
+
+;; Set up the Dbus event loop as prompt-event handler
+(prompt-event Dbus:main-loop)
+
+;;######################################################################
+;;
+;; Some tidbits
+
+;;org.freedesktop.DBus.Peer.Ping ()
+;;org.freedesktop.DBus.Peer.GetMachineId (out STRING machine_uuid)
+;;org.freedesktop.DBus.Introspectable.Introspect (out STRING xml_data)
+;;org.freedesktop.DBus.Properties.Get (
+;;            in STRING interface_name,
+;;            in STRING property_name,
+;;            out VARIANT value);
+;;org.freedesktop.DBus.Properties.Set (
+;;            in STRING interface_name,
+;;            in STRING property_name,
+;;            in VARIANT value);
+;;org.freedesktop.DBus.Properties.GetAll (
+;;            in STRING interface_name,
+;;            out ARRAY of DICT_ENTRY<STRING,VARIANT> props);
+;;org.freedesktop.DBus.Properties.PropertiesChanged (
+;;            STRING interface_name,
+;;            ARRAY of DICT_ENTRY<STRING,VARIANT> changed_properties,
+;;            ARRAY<STRING> invalidated_properties);
+;;org.freedesktop.DBus.ObjectManager.GetManagedObjects (
+;;            out ARRAY of
+;;               DICT_ENTRY<OBJPATH,ARRAY of
+;;                  DICT_ENTRY<STRING,ARRAY of
+;;                     DICT_ENTRY<STRING,VARIANT>>>
+;;            objpath_interfaces_and_properties);
+;;;;
+;;org.freedesktop.DBus.Hello():s
+;;org.freedesktop.DBus.RequestName(su):u
+;;org.freedesktop.DBus.ReleaseName(s):u
+;;org.freedesktop.DBus.ListQueuedOwners (s):as
+;;org.freedesktop.DBus.ListNames():as
+;;org.freedesktop.DBus.ListActivatableNames():as
+;;org.freedesktop.DBus.NameHasOwner(s):b
+;;org.freedesktop.DBus.NameOwnerChanged(sss) -- signal
+;;org.freedesktop.DBus.NameLost(s) -- signal
+;;org.freedesktop.DBus.NameAcquired(s) -- signal
+;;org.freedesktop.DBus.ActivatableServicesChanged() -- signal
+;;org.freedesktop.DBus.StartServiceByName(s,u):u
+;;org.freedesktop.DBus.UpdateActivationEnvironment(a(ss)):?
+;;org.freedesktop.DBus.GetNameOwner(s):s
+;;org.freedesktop.DBus.GetConnectionUnixUser(s):u
+;;org.freedesktop.DBus.GetConnectionUnixProcessID(s):u
+;;org.freedesktop.DBus.GetConnectionCredentials(s):a(sv)
+;;org.freedesktop.DBus.GetAdtAuditSessionData(s):ay
+;;org.freedesktop.DBus.GetConnectionSELinuxSecurityContext(s):ay
+;;org.freedesktop.DBus.AddMatch(s):? (org.freedesktop.DBus.Error.OOM)
+;;org.freedesktop.DBus.RemoveMatch(s):?
+;;org.freedesktop.DBus.GetId():s
+;;org.freedesktop.DBus.Monitoring.BecomeMonitor(asu):?
+
+;;org.freedesktop.DBus.AddMatch(s)
+;eg 
+;"type='signal',sender='org.example.App2',path_namespace='/org/example/App2'"
+
+;;org.freedesktop.DBus.StartServiceByName(?)
+;;org.freedesktop.DBus.NameOwnerChanged(?)
 
 "lsp-dbus.lsp"