1 ;; This newlisp "module" sets up a dbus API adapter
3 ;; dbus is an object oriented interprocess commmunications framework
4 ;; based on utual object proxying. This end holds some objects that
5 ;; remote ends can access and invoke methods on, and remote ends hold
6 ;; objects that this pocess can access and invoke methods on.
8 ;; https://dbus.freedesktop.org/doc/dbus-specification.html
9 ;; https://dbus.freedesktop.org/doc/dbus-api-design.html
10 ;; [C API] https://dbus.freedesktop.org/doc/api/html/
13 (unless (context? MAIN:FOOP) (load "foop.lsp"))
14 (unless (context? MAIN:prog1) (load "misc.lsp"))
15 (unless (context? MAIN:DbusConnection) (load "lsp-dbus-connection.lsp"))
17 #################################################################
20 ;; Declaring the FOOP object
23 ;; "The FOOP Constructor". Creates an object for a given path.
24 (define (Dbus:Dbus PATH (BUS 'SYSTEM-BUS))
25 (list (context) PATH BUS))
27 ;; Return the bus name
29 (join (find-all "([^/]+)" (%path) $1 0) "."))
31 ;; Update the connection serial and return it
32 (define (connection++)
34 (SYSTEM-BUS (:serial++ SYSTEM-BUS))
37 ; Include marshalling functions and signal handling framework
38 (load "lsp-dbus-marshal.lsp" (context))
39 (load "lsp-dbus-events.lsp" (context))
41 ;; ====================
45 'PROTOCOL-VERSION '(1 1)
46 'MESSAGE-TYPES '(INVALID METHOD_CALL METHOD_RETURN ERROR SIGNAL)
47 'MESSAGE-FLAGS '(NO_REPLY_EXPECTED
49 ALLOW_INTERACTIVE_AUTHORIZATION)
50 ;; Message headers: [code] => (name type)
51 'MESSAGE-HEADERS '((INVALID )
64 ;; Map message type symbol to dbus type code (i.e. the list index)
65 (define (message-type-code TYPE)
66 (or (find TYPE MESSAGE-TYPES =) 0))
68 ;; Map flag symbol F to its dbus "bit code"
70 (if (find F MESSAGE-FLAGS) (pow 2 $it) 0))
72 ;; Return the dbus flags code from FLAGS; if it is a number thent tha
73 ;; is returned as is; if FLAGS is a list of message flag symbols then
74 ;; combine their codes by bit-OR. Anything else yields 0.
75 (define (message-flags FLAGS)
76 (if (number? FLAGS) FLAGS
78 (apply | (map flag FLAGS))
81 ;; (message-header (NAME VALUE))
82 ; Translate header into its marshalling data. The name is mapped to
83 ; its header code and associated value type. This gets translated into
84 ; the marshalling data form of (code (type value))
85 (define (message-header HDR)
87 (if (find (list (HDR 0) '*) MESSAGE-HEADERS match)
88 (list $it (list (MESSAGE-HEADERS $it -1) (HDR 1))))))
90 ;; Join the excess string arguments N-byte alignment successively
94 (let ((PAD (dup "\000" (% (- N (% (length OUT) N)) N))))
98 ;; Return a marshalled message string appended by the marshalled body
99 (define (message TYPE FLAGS HDRS BODY)
101 (pack-data "yyyyuua(yv)"
103 (message-type-code TYPE)
104 (message-flags FLAGS)
105 (PROTOCOL-VERSION 0) ; Major version code
108 (clean null? (map message-header HDRS))))
111 ;; (:invoke OBJ METHOD ARGS FLAGS)
112 ; Perform a METHOD_CALL on the (self) object
113 ;; The given METHOD has format "INTERFACE.NAME(SIGNATURE)" with the
114 ;; "INTERFACE." bit optional. The function returns the list of headers
115 ;; of the reply message extended with reply value as a faked header
118 ;; This function calls send-recv-message which also polls for signals
119 ;; until a reply is given, but any such signals are stocked up as
120 ;; pending for later processing on demand.
121 (define (invoke METHOD ARGS (FLAGS 0))
122 (when (regex "((.+):)?((.+)\\.)?([^(]+)\\((.*)\\)$" METHOD 0)
123 (let ((PATH $2) (INTERFACE $4) (MEMBER $5) (SIGNATURE $6))
124 ;;(println (list 'invoke (bus-name) INTERFACE MEMBER SIGNATURE))
125 (if (message 'METHOD_CALL FLAGS
126 (list nil ; (if SELF-NAME (list 'SENDER SELF-NAME))
127 (list 'DESTINATION (bus-name))
128 (list 'PATH (if (empty? PATH) (%path) PATH))
129 (if (empty? INTERFACE) nil
130 (list 'INTERFACE INTERFACE))
131 (list 'MEMBER MEMBER)
132 (if (empty? SIGNATURE) nil
133 (list 'SIGNATURE SIGNATURE))
135 (if (empty? SIGNATURE) ""
136 (pack-data SIGNATURE ARGS)))
137 (send-recv-message $it)
141 ;; Context variables and framework registration
144 SYSTEM-BUS (MAIN:DbusConnection "/run/dbus/system_bus_socket")
145 APPID (:initialize SYSTEM-BUS)
146 ROOT (Dbus "/org/freedesktop/DBus")
147 APPNAME (if (lookup "" (:invoke ROOT "org.freedesktop.DBus.Hello()"))
151 ;; Installation of some framework notification handlers
153 ;; Helper method to notify
154 (define (signal-trace ARGS)
155 (die nil "** Got:" KEY ARGS ))
157 (:handler ROOT "org.freedesktop.DBus.NameAcquired(s)" signal-trace)
158 (:handler ROOT "org.freedesktop.DBus.NameLost(s)" signal-trace)
159 (:handler ROOT "org.freedesktop.DBus.NameOwnerChanged(sss)" signal-trace)
161 ; Process notifications that came with the registration handshake
162 (process-all-pending)
164 ;; Set up the Dbus event loop as prompt-event handler
165 (prompt-event Dbus:main-loop)
167 ;;######################################################################
171 ;;org.freedesktop.DBus.Peer.Ping ()
172 ;;org.freedesktop.DBus.Peer.GetMachineId (out STRING machine_uuid)
173 ;;org.freedesktop.DBus.Introspectable.Introspect (out STRING xml_data)
174 ;;org.freedesktop.DBus.Properties.Get (
175 ;; in STRING interface_name,
176 ;; in STRING property_name,
177 ;; out VARIANT value);
178 ;;org.freedesktop.DBus.Properties.Set (
179 ;; in STRING interface_name,
180 ;; in STRING property_name,
181 ;; in VARIANT value);
182 ;;org.freedesktop.DBus.Properties.GetAll (
183 ;; in STRING interface_name,
184 ;; out ARRAY of DICT_ENTRY<STRING,VARIANT> props);
185 ;;org.freedesktop.DBus.Properties.PropertiesChanged (
186 ;; STRING interface_name,
187 ;; ARRAY of DICT_ENTRY<STRING,VARIANT> changed_properties,
188 ;; ARRAY<STRING> invalidated_properties);
189 ;;org.freedesktop.DBus.ObjectManager.GetManagedObjects (
191 ;; DICT_ENTRY<OBJPATH,ARRAY of
192 ;; DICT_ENTRY<STRING,ARRAY of
193 ;; DICT_ENTRY<STRING,VARIANT>>>
194 ;; objpath_interfaces_and_properties);
195 ;;org.freedesktop.DBus.ObjectManager.GetManagedObjects():a(oa(sa(sv)))
197 ;;org.freedesktop.DBus.Hello():s
198 ;;org.freedesktop.DBus.RequestName(su):u
199 ;;org.freedesktop.DBus.ReleaseName(s):u
200 ;;org.freedesktop.DBus.ListQueuedOwners (s):as
201 ;;org.freedesktop.DBus.ListNames():as
202 ;;org.freedesktop.DBus.ListActivatableNames():as
203 ;;org.freedesktop.DBus.NameHasOwner(s):b
204 ;;org.freedesktop.DBus.NameOwnerChanged(sss) -- signal
205 ;;org.freedesktop.DBus.NameLost(s) -- signal
206 ;;org.freedesktop.DBus.NameAcquired(s) -- signal
207 ;;org.freedesktop.DBus.ActivatableServicesChanged() -- signal
208 ;;org.freedesktop.DBus.StartServiceByName(s,u):u
209 ;;org.freedesktop.DBus.UpdateActivationEnvironment(a(ss)):?
210 ;;org.freedesktop.DBus.GetNameOwner(s):s
211 ;;org.freedesktop.DBus.GetConnectionUnixUser(s):u
212 ;;org.freedesktop.DBus.GetConnectionUnixProcessID(s):u
213 ;;org.freedesktop.DBus.GetConnectionCredentials(s):a(sv)
214 ;;org.freedesktop.DBus.GetAdtAuditSessionData(s):ay
215 ;;org.freedesktop.DBus.GetConnectionSELinuxSecurityContext(s):ay
216 ;;org.freedesktop.DBus.AddMatch(s):? (org.freedesktop.DBus.Error.OOM)
217 ;;org.freedesktop.DBus.RemoveMatch(s):?
218 ;;org.freedesktop.DBus.GetId():s
219 ;;org.freedesktop.DBus.Monitoring.BecomeMonitor(asu):?
221 ;;org.freedesktop.DBus.AddMatch(s)
223 ;"type='signal',sender='org.example.App2',path_namespace='/org/example/App2'"
225 ;;org.freedesktop.DBus.StartServiceByName(?)
226 ;;org.freedesktop.DBus.NameOwnerChanged(?)
228 ;; org.freedesktop.DBus.Introspectable.Introspect():s (xml data)
229 ;; https://dbus.freedesktop.org/doc/dbus-specification.html#introspection-format