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 #################################################################
18 ;; The DbusInterface context is used for modelling DBus interfaces.
20 ;; It includes in particular the :use method for installing a
21 ;; DbusInterface FOOP object as a constant named by the interface.
22 ;; E.g. (:use (DbusInterface "org.freedesktop.DBus.ObjectManager")
23 ;; installes the constant ObjectManager with a DbusInterface FOOP
24 ;; object modelling that interface.
26 ;; The :m method is used to construct a fullly qualified method name.
27 ;; E.g. (:m ObjectManager "GetManagedObjects()") assuming the prior
28 ;; :use installation of ObjectManager results in the fully qualified
30 ;; "org.freedesktop.DBus.ObjectManager.GetManagedObjects()"
32 (context 'DbusInterface)
35 ;; FOOP constructor; remember the interface name
36 (define (DbusInterface:DbusInterface NAME (MEMBERS '()))
37 (list (context) NAME MEMBERS))
39 ;; Utility method to expand a member with the interface prefix. When
40 ;; the MEMBER is given without "(", then it is duly looked up in the
41 ;; MEMBERS list of the DbusInterface, and it thus gets expanded with
42 ;; parameter signature.
44 (unless (find "(" MEMBER)
45 (if (ref (string MEMBER "(") (%members) (fn (x y) (starts-with y x)) true)
46 (setf MEMBER ((parse $it ":") 0))))
47 (string (%name) "." MEMBER))
49 ;; Install this interface into the context of the caller
51 (let ((IF (when (regex "([^.]+)$" (%name) 0) $1))
52 (CC (prefix (first (or (1 (history)) '(MAIN))))))
53 (letex ((S (sym $1 CC)) (V (self)))
54 (begin (context CC) (constant 'S 'V)))))
56 ;; Declare additional members for this interface
58 (dolist (MEMBER (args))
59 (unless (member MEMBER (%members))
60 (!members (push MEMBER (%members) -1)))))
62 #################################################################
65 ;; Declaring the FOOP object
68 ;; "The FOOP Constructor". Creates an object for a given path.
69 (define (Dbus:Dbus PATH (NAME (replace "/" (1 PATH) ".")) (BUS 'SYSTEM-BUS))
70 (list (context) PATH NAME BUS))
72 ;; Method to clone a proxy for a given path/object.
73 (define (new-path PATH)
74 (list (context) PATH (%name) (%bus)))
76 ;; Update the connection serial and return it
77 (define (connection++)
79 (SYSTEM-BUS (:serial++ SYSTEM-BUS))
82 ; Include marshalling functions and signal handling framework
83 (load "lsp-dbus-marshal.lsp" (context))
84 (load "lsp-dbus-events.lsp" (context))
86 ;; ====================
90 'PROTOCOL-VERSION '(1 1)
91 'MESSAGE-TYPES '(INVALID METHOD_CALL METHOD_RETURN ERROR SIGNAL)
92 'MESSAGE-FLAGS '(NO_REPLY_EXPECTED
94 ALLOW_INTERACTIVE_AUTHORIZATION)
95 ;; Message headers: [code] => (name type)
96 'MESSAGE-HEADERS '((INVALID )
109 ;; Map message type symbol to dbus type code (i.e. the list index)
110 (define (message-type-code TYPE)
111 (or (find TYPE MESSAGE-TYPES =) 0))
113 ;; Map flag symbol F to its dbus "bit code"
115 (if (find F MESSAGE-FLAGS) (pow 2 $it) 0))
117 ;; Return the dbus flags code from FLAGS; if it is a number thent tha
118 ;; is returned as is; if FLAGS is a list of message flag symbols then
119 ;; combine their codes by bit-OR. Anything else yields 0.
120 (define (message-flags FLAGS)
121 (if (number? FLAGS) FLAGS
123 (apply | (map flag FLAGS))
126 ;; (message-header (NAME VALUE))
127 ; Translate header into its marshalling data. The name is mapped to
128 ; its header code and associated value type. This gets translated into
129 ; the marshalling data form of (code (type value))
130 (define (message-header HDR)
132 (if (find (list (HDR 0) '*) MESSAGE-HEADERS match)
133 (list $it (list (MESSAGE-HEADERS $it -1) (HDR 1))))))
135 ;; Join the excess string arguments N-byte alignment successively
139 (let ((PAD (dup "\000" (% (- N (% (length OUT) N)) N))))
143 ;; Return a marshalled message string appended by the marshalled body
144 (define (message TYPE FLAGS HDRS BODY)
146 (pack-data "yyyyuua(yv)"
148 (message-type-code TYPE)
149 (message-flags FLAGS)
150 (PROTOCOL-VERSION 0) ; Major version code
153 (clean null? (map message-header HDRS))))
156 ;; (:invoke OBJ METHOD ARGS FLAGS)
157 ; Perform a METHOD_CALL on the (self) object
158 ;; The given METHOD has format "INTERFACE.NAME(SIGNATURE)" with the
159 ;; "INTERFACE." bit optional. The function returns the list of headers
160 ;; of the reply message extended with reply value as a faked header
163 ;; This function calls send-recv-message which also polls for signals
164 ;; until a reply is given, but any such signals are stocked up as
165 ;; pending for later processing on demand.
166 (define (invoke METHOD ARGS (FLAGS 0))
167 (when (regex "((.+):)?((.+)\\.)?([^(]+)\\((.*)\\)$" METHOD 0)
168 (let ((PATH $2) (INTERFACE $4) (MEMBER $5) (SIGNATURE $6))
169 ;;(println (list 'invoke (%name) INTERFACE MEMBER SIGNATURE))
170 (if (message 'METHOD_CALL FLAGS
171 (list nil ; (if SELF-NAME (list 'SENDER SELF-NAME))
172 (list 'DESTINATION (%name))
173 (list 'PATH (if (empty? PATH) (%path) PATH))
174 (if (empty? INTERFACE) nil
175 (list 'INTERFACE INTERFACE))
176 (list 'MEMBER MEMBER)
177 (if (empty? SIGNATURE) nil
178 (list 'SIGNATURE SIGNATURE))
180 (if (empty? SIGNATURE) ""
181 (pack-data SIGNATURE ARGS)))
182 (send-recv-message $it)
186 ;; Context variables and framework registration
188 SYSTEM-BUS (MAIN:DbusConnection "/run/dbus/system_bus_socket")
189 APPID (:initialize SYSTEM-BUS)
190 ROOT (Dbus "/org/freedesktop/DBus")
191 DBus (DbusInterface "org.freedesktop.DBus")
192 APPNAME (if (:invoke ROOT (:m DBus "Hello()"))
196 ;; Installation of some framework notification handlers
198 ;; Helper method to notify
199 (define (signal-trace ARGS)
200 (die nil "** Got:" KEY ARGS ))
202 (:handler ROOT (:m DBus "NameAcquired(s)") signal-trace)
203 (:handler ROOT (:m DBus "NameLost(s)") signal-trace)
204 (:handler ROOT (:m DBus "NameOwnerChanged(sss)") signal-trace)
206 ; Process notifications that came with the registration handshake
207 (process-all-pending)
209 ;; Set up the Dbus event loop as prompt-event handler
210 (prompt-event Dbus:main-loop)
212 ;;######################################################################
214 ;; Standard interfaces
218 (:use (DbusInterface "org.freedesktop.DBus.Peer"
223 (:use (DbusInterface "org.freedesktop.DBus.ObjectManager"
224 '( "GetManagedObjects():a(oa(sa(sv)))"
227 (:use (DbusInterface "org.freedesktop.DBus.Introspectable"
228 ' Introspectable "Introspect():s" ; (xml data)
230 ; https://dbus.freedesktop.org/doc/dbus-specification.html#introspection-format
232 (:use (DbusInterface "org.freedesktop.DBus.Properties"
236 "PropertiesChanged(sa(sv)as):" ; signal ?
239 (:use (DbusInterface "org.freedesktop.DBus"
243 "ListQueuedOwners (s):as"
245 "ListActivatableNames():as"
247 "NameOwnerChanged(sss):" ; -- signal
248 "NameLost(s):" ; -- signal
249 "NameAcquired(s):" ; -- signal
250 "ActivatableServicesChanged():" ; -- signal
251 "StartServiceByName(s,u):u"
252 "UpdateActivationEnvironment(a(ss)):"
254 "GetConnectionUnixUser(s):u"
255 "GetConnectionUnixProcessID(s):u"
256 "GetConnectionCredentials(s):a(sv)"
257 "GetAdtAuditSessionData(s):ay"
258 "GetConnectionSELinuxSecurityContext(s):ay"
262 "Monitoring.BecomeMonitor(asu):"
265 ;eg AddMatch argument:
266 ;"type='signal',sender='org.example.App2',path_namespace='/org/example/App2'"