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 ;; Update the connection serial and return it
73 (define (connection++)
75 (SYSTEM-BUS (:serial++ SYSTEM-BUS))
78 ; Include marshalling functions and signal handling framework
79 (load "lsp-dbus-marshal.lsp" (context))
80 (load "lsp-dbus-events.lsp" (context))
82 ;; ====================
86 'PROTOCOL-VERSION '(1 1)
87 'MESSAGE-TYPES '(INVALID METHOD_CALL METHOD_RETURN ERROR SIGNAL)
88 'MESSAGE-FLAGS '(NO_REPLY_EXPECTED
90 ALLOW_INTERACTIVE_AUTHORIZATION)
91 ;; Message headers: [code] => (name type)
92 'MESSAGE-HEADERS '((INVALID )
105 ;; Map message type symbol to dbus type code (i.e. the list index)
106 (define (message-type-code TYPE)
107 (or (find TYPE MESSAGE-TYPES =) 0))
109 ;; Map flag symbol F to its dbus "bit code"
111 (if (find F MESSAGE-FLAGS) (pow 2 $it) 0))
113 ;; Return the dbus flags code from FLAGS; if it is a number thent tha
114 ;; is returned as is; if FLAGS is a list of message flag symbols then
115 ;; combine their codes by bit-OR. Anything else yields 0.
116 (define (message-flags FLAGS)
117 (if (number? FLAGS) FLAGS
119 (apply | (map flag FLAGS))
122 ;; (message-header (NAME VALUE))
123 ; Translate header into its marshalling data. The name is mapped to
124 ; its header code and associated value type. This gets translated into
125 ; the marshalling data form of (code (type value))
126 (define (message-header HDR)
128 (if (find (list (HDR 0) '*) MESSAGE-HEADERS match)
129 (list $it (list (MESSAGE-HEADERS $it -1) (HDR 1))))))
131 ;; Join the excess string arguments N-byte alignment successively
135 (let ((PAD (dup "\000" (% (- N (% (length OUT) N)) N))))
139 ;; Return a marshalled message string appended by the marshalled body
140 (define (message TYPE FLAGS HDRS BODY)
142 (pack-data "yyyyuua(yv)"
144 (message-type-code TYPE)
145 (message-flags FLAGS)
146 (PROTOCOL-VERSION 0) ; Major version code
149 (clean null? (map message-header HDRS))))
152 ;; (:invoke OBJ METHOD ARGS FLAGS)
153 ; Perform a METHOD_CALL on the (self) object
154 ;; The given METHOD has format "INTERFACE.NAME(SIGNATURE)" with the
155 ;; "INTERFACE." bit optional. The function returns the list of headers
156 ;; of the reply message extended with reply value as a faked header
159 ;; This function calls send-recv-message which also polls for signals
160 ;; until a reply is given, but any such signals are stocked up as
161 ;; pending for later processing on demand.
162 (define (invoke METHOD ARGS (FLAGS 0))
163 (when (regex "((.+):)?((.+)\\.)?([^(]+)\\((.*)\\)$" METHOD 0)
164 (let ((PATH $2) (INTERFACE $4) (MEMBER $5) (SIGNATURE $6))
165 ;;(println (list 'invoke (%name) INTERFACE MEMBER SIGNATURE))
166 (if (message 'METHOD_CALL FLAGS
167 (list nil ; (if SELF-NAME (list 'SENDER SELF-NAME))
168 (list 'DESTINATION (%name))
169 (list 'PATH (if (empty? PATH) (%path) PATH))
170 (if (empty? INTERFACE) nil
171 (list 'INTERFACE INTERFACE))
172 (list 'MEMBER MEMBER)
173 (if (empty? SIGNATURE) nil
174 (list 'SIGNATURE SIGNATURE))
176 (if (empty? SIGNATURE) ""
177 (pack-data SIGNATURE ARGS)))
178 (send-recv-message $it)
182 ;; Context variables and framework registration
184 SYSTEM-BUS (MAIN:DbusConnection "/run/dbus/system_bus_socket")
185 APPID (:initialize SYSTEM-BUS)
186 ROOT (Dbus "/org/freedesktop/DBus")
187 DBus (DbusInterface "org.freedesktop.DBus")
188 APPNAME (if (:invoke ROOT (:m DBus "Hello()"))
192 ;; Installation of some framework notification handlers
194 ;; Helper method to notify
195 (define (signal-trace ARGS)
196 (die nil "** Got:" KEY ARGS ))
198 (:handler ROOT (:m DBus "NameAcquired(s)") signal-trace)
199 (:handler ROOT (:m DBus "NameLost(s)") signal-trace)
200 (:handler ROOT (:m DBus "NameOwnerChanged(sss)") signal-trace)
202 ; Process notifications that came with the registration handshake
203 (process-all-pending)
205 ;; Set up the Dbus event loop as prompt-event handler
206 (prompt-event Dbus:main-loop)
208 ;;######################################################################
210 ;; Standard interfaces
214 (:use (DbusInterface "org.freedesktop.DBus.Peer"
219 (:use (DbusInterface "org.freedesktop.DBus.ObjectManager"
220 '( "GetManagedObjects():a(oa(sa(sv)))"
223 (:use (DbusInterface "org.freedesktop.DBus.Introspectable"
224 ' Introspectable "Introspect():s" ; (xml data)
226 ; https://dbus.freedesktop.org/doc/dbus-specification.html#introspection-format
228 (:use (DbusInterface "org.freedesktop.DBus.Properties"
232 "PropertiesChanged(sa(sv)as):" ; signal ?
235 (:use (DbusInterface "org.freedesktop.DBus"
239 "ListQueuedOwners (s):as"
241 "ListActivatableNames():as"
243 "NameOwnerChanged(sss):" ; -- signal
244 "NameLost(s):" ; -- signal
245 "NameAcquired(s):" ; -- signal
246 "ActivatableServicesChanged():" ; -- signal
247 "StartServiceByName(s,u):u"
248 "UpdateActivationEnvironment(a(ss)):"
250 "GetConnectionUnixUser(s):u"
251 "GetConnectionUnixProcessID(s):u"
252 "GetConnectionCredentials(s):a(sv)"
253 "GetAdtAuditSessionData(s):ay"
254 "GetConnectionSELinuxSecurityContext(s):ay"
258 "Monitoring.BecomeMonitor(asu):"
261 ;eg AddMatch argument:
262 ;"type='signal',sender='org.example.App2',path_namespace='/org/example/App2'"