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 (NAME (replace "/" (1 PATH) ".")) (BUS 'SYSTEM-BUS))
25 (list (context) PATH NAME BUS))
27 ;; Update the connection serial and return it
28 (define (connection++)
30 (SYSTEM-BUS (:serial++ SYSTEM-BUS))
33 ; Include marshalling functions and signal handling framework
34 (load "lsp-dbus-marshal.lsp" (context))
35 (load "lsp-dbus-events.lsp" (context))
37 ;; ====================
41 'PROTOCOL-VERSION '(1 1)
42 'MESSAGE-TYPES '(INVALID METHOD_CALL METHOD_RETURN ERROR SIGNAL)
43 'MESSAGE-FLAGS '(NO_REPLY_EXPECTED
45 ALLOW_INTERACTIVE_AUTHORIZATION)
46 ;; Message headers: [code] => (name type)
47 'MESSAGE-HEADERS '((INVALID )
60 ;; Map message type symbol to dbus type code (i.e. the list index)
61 (define (message-type-code TYPE)
62 (or (find TYPE MESSAGE-TYPES =) 0))
64 ;; Map flag symbol F to its dbus "bit code"
66 (if (find F MESSAGE-FLAGS) (pow 2 $it) 0))
68 ;; Return the dbus flags code from FLAGS; if it is a number thent tha
69 ;; is returned as is; if FLAGS is a list of message flag symbols then
70 ;; combine their codes by bit-OR. Anything else yields 0.
71 (define (message-flags FLAGS)
72 (if (number? FLAGS) FLAGS
74 (apply | (map flag FLAGS))
77 ;; (message-header (NAME VALUE))
78 ; Translate header into its marshalling data. The name is mapped to
79 ; its header code and associated value type. This gets translated into
80 ; the marshalling data form of (code (type value))
81 (define (message-header HDR)
83 (if (find (list (HDR 0) '*) MESSAGE-HEADERS match)
84 (list $it (list (MESSAGE-HEADERS $it -1) (HDR 1))))))
86 ;; Join the excess string arguments N-byte alignment successively
90 (let ((PAD (dup "\000" (% (- N (% (length OUT) N)) N))))
94 ;; Return a marshalled message string appended by the marshalled body
95 (define (message TYPE FLAGS HDRS BODY)
97 (pack-data "yyyyuua(yv)"
99 (message-type-code TYPE)
100 (message-flags FLAGS)
101 (PROTOCOL-VERSION 0) ; Major version code
104 (clean null? (map message-header HDRS))))
107 ;; (:invoke OBJ METHOD ARGS FLAGS)
108 ; Perform a METHOD_CALL on the (self) object
109 ;; The given METHOD has format "INTERFACE.NAME(SIGNATURE)" with the
110 ;; "INTERFACE." bit optional. The function returns the list of headers
111 ;; of the reply message extended with reply value as a faked header
114 ;; This function calls send-recv-message which also polls for signals
115 ;; until a reply is given, but any such signals are stocked up as
116 ;; pending for later processing on demand.
117 (define (invoke METHOD ARGS (FLAGS 0))
118 (when (regex "((.+):)?((.+)\\.)?([^(]+)\\((.*)\\)$" METHOD 0)
119 (let ((PATH $2) (INTERFACE $4) (MEMBER $5) (SIGNATURE $6))
120 ;;(println (list 'invoke (%name) INTERFACE MEMBER SIGNATURE))
121 (if (message 'METHOD_CALL FLAGS
122 (list nil ; (if SELF-NAME (list 'SENDER SELF-NAME))
123 (list 'DESTINATION (%name))
124 (list 'PATH (if (empty? PATH) (%path) PATH))
125 (if (empty? INTERFACE) nil
126 (list 'INTERFACE INTERFACE))
127 (list 'MEMBER MEMBER)
128 (if (empty? SIGNATURE) nil
129 (list 'SIGNATURE SIGNATURE))
131 (if (empty? SIGNATURE) ""
132 (pack-data SIGNATURE ARGS)))
133 (send-recv-message $it)
137 ;; Context variables and framework registration
140 SYSTEM-BUS (MAIN:DbusConnection "/run/dbus/system_bus_socket")
141 APPID (:initialize SYSTEM-BUS)
142 ROOT (Dbus "/org/freedesktop/DBus")
143 APPNAME (if (lookup "" (:invoke ROOT "org.freedesktop.DBus.Hello()"))
147 ;; Installation of some framework notification handlers
149 ;; Helper method to notify
150 (define (signal-trace ARGS)
151 (die nil "** Got:" KEY ARGS ))
153 (:handler ROOT "org.freedesktop.DBus.NameAcquired(s)" signal-trace)
154 (:handler ROOT "org.freedesktop.DBus.NameLost(s)" signal-trace)
155 (:handler ROOT "org.freedesktop.DBus.NameOwnerChanged(sss)" signal-trace)
157 ; Process notifications that came with the registration handshake
158 (process-all-pending)
160 ;; Set up the Dbus event loop as prompt-event handler
161 (prompt-event Dbus:main-loop)
163 (context 'DbusInterface)
166 ;; FOOP constructor; remember the interface name
167 (define (DbusInterface:DbusInterface NAME (MEMBERS '()))
168 (list (context) NAME MEMBERS))
170 ;; Utility method to expand a member with interface prefix
172 (string (%name) "." MEMBER))
174 ;; Install this interface into the context of the caller
176 (let ((IF (when (regex "([^.]+)$" (%name) 0) $1))
177 (CC (prefix (first (or (1 (history)) '(MAIN))))))
178 (letex ((S (sym $1 CC)) (V (self)))
179 (begin (context CC) (constant 'S 'V)))))
181 ;; Declare additional members for this interface
183 (dolist (MEMBER (args))
184 (unless (member MEMBER (%members))
185 (!members (push MEMBER (%members) -1)))))
187 ;;######################################################################
189 ;; Standard interfaces
193 (:use (DbusInterface "org.freedesktop.DBus.Peer"
198 (:use (DbusInterface "org.freedesktop.DBus.ObjectManager"
199 '( "GetManagedObjects()" ; a(oa(sa(sv)))
202 (:use (DbusInterface "org.freedesktop.DBus.Introspectable"
203 ' Introspectable "Introspect()" ; s (xml data)
205 ; https://dbus.freedesktop.org/doc/dbus-specification.html#introspection-format
207 (:use (DbusInterface "org.freedesktop.DBus.Properties"
211 "PropertiesChanged(sa(sv)as)" ; signal ?
214 (:use (DbusInterface "org.freedesktop.DBus"
216 "RequestName(su)" ; u
218 "ListQueuedOwners (s)" ; as
220 "ListActivatableNames()" ; as
221 "NameHasOwner(s)" ; b
222 "NameOwnerChanged(sss)" ; -- signal
223 "NameLost(s)" ; -- signal
224 "NameAcquired(s)" ; -- signal
225 "ActivatableServicesChanged()" ; -- signal
226 "StartServiceByName(s,u)" ; u
227 "UpdateActivationEnvironment(a(ss))" ; ?
228 "GetNameOwner(s)" ; s
229 "GetConnectionUnixUser(s)" ; u
230 "GetConnectionUnixProcessID(s)" ; u
231 "GetConnectionCredentials(s)" ; a(sv)
232 "GetAdtAuditSessionData(s)" ; ay
233 "GetConnectionSELinuxSecurityContext(s)" ; ay
237 "Monitoring.BecomeMonitor(asu)" ; ?
240 ;eg AddMatch argument:
241 ;"type='signal',sender='org.example.App2',path_namespace='/org/example/App2'"