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 ; Require the FOOP context
14 (unless (context? MAIN:FOOP) (load "foop.lsp"))
16 #################################################################
17 ;; This newlisp module implements dbus socket connection
18 ;; originally lsp-dbus-connection.lsp
20 (context 'MAIN:DbusConnection)
21 (FOOP path socket name serial)
23 (define (DbusConnection:DbusConnection PATH)
24 (list (context) PATH -1 nil 0))
26 ;; Increment the serial and return it.
28 (!serial (+ 1 (%serial))))
31 ; Internal utility method to re-open the %path socket and set the
37 (!socket (net-connect (%path))))
39 ;** Commands from client to server
40 ; AUTH [mechanism] [initial-response]
43 ; DATA <data in hex encoding>
44 ; ERROR [human-readable error explanation]
47 ;** Commands from server to client
48 ; REJECTED <space-separated list of mechanism names>
50 ; DATA <data in hex encoding>
51 ; ERROR [human-readable error explanation]
54 (define (read-message)
55 (let ((BUFFER "") (RESULT ""))
56 (while (and RESULT (net-select (%socket) "r" 1000))
57 (if (net-receive (%socket) BUFFER 8192)
58 (extend RESULT BUFFER)
61 (die 1 "dbus socket closed"))
65 ;; (handshake MSG PAT)
66 ; Perform a socket handshake sending MSG and return the result, or if
67 ; PAT not nil, then return (regex PAT RESULT 0),
68 (define (handshake MSG PAT)
70 (net-send (%socket) MSG)
71 (setf RESULT (read-message))
72 (if PAT (regex PAT RESULT 0) RESULT)))
75 'AUTHFMT "AUTH EXTERNAL %s\r\n"
76 'AUTHACK "OK (\\S+)\r\n"
77 'KEEPFMT "NEGOTIATE_UNIX_FD\r\n"
78 'KEEPACK "AGREE_UNIX_FD\r\n"
82 ; Perform socket initialization sequence and return the name, or nil.
83 (define (initialize (USER (env "USER")))
84 (when (and (>= (open-socket))
85 (net-send (%socket) (char 0))
86 (handshake (format AUTHFMT (char2hex USER)) AUTHACK)
88 (handshake KEEPFMT KEEPACK))
89 (handshake "BEGIN\r\n")
93 (handshake "CANCEL\r\n" "(.*)"))
95 #################################################################
96 ;; The DbusInterface context is used for modelling DBus interfaces.
98 ;; It includes in particular the :use method for installing a
99 ;; DbusInterface FOOP object as a constant named by the interface.
100 ;; E.g. (:use (DbusInterface "org.freedesktop.DBus.ObjectManager")
101 ;; installes the constant ObjectManager with a DbusInterface FOOP
102 ;; object modelling that interface.
104 ;; The :m method is used to construct a fullly qualified method name.
105 ;; E.g. (:m ObjectManager "GetManagedObjects()") assuming the prior
106 ;; :use installation of ObjectManager results in the fully qualified
108 ;; "org.freedesktop.DBus.ObjectManager.GetManagedObjects()"
110 (context 'MAIN:DbusInterface)
113 ;; FOOP constructor; remember the interface name
114 (define (DbusInterface:DbusInterface NAME (MEMBERS '()))
115 (list (context) NAME MEMBERS))
117 ;; Utility method to expand a member with the interface prefix. When
118 ;; the MEMBER is given without "(", then it is duly looked up in the
119 ;; MEMBERS list of the DbusInterface, and it thus gets expanded with
120 ;; parameter signature.
122 (unless (find "(" MEMBER)
123 (if (ref (string MEMBER "(") (%members) (fn (x y) (starts-with y x)) true)
124 (setf MEMBER ((parse $it ":") 0))))
125 (string (%name) "." MEMBER))
127 ;; Install this interface into the context of the caller
129 (let ((IF (when (regex "([^.]+)$" (%name) 0) $1))
130 (CC (prefix (first (or (1 (history)) '(MAIN))))))
131 (letex ((S (sym $1 CC)) (V (self)))
132 (begin (context CC) (constant 'S 'V)))))
134 ;; Declare additional members for this interface
136 (dolist (MEMBER (args))
137 (unless (member MEMBER (%members))
138 (!members (push MEMBER (%members) -1)))))
140 #################################################################
143 ;; Declaring the FOOP object
146 ;; "The FOOP Constructor". Creates an object for a given path.
147 (define (Dbus:Dbus PATH (NAME (replace "/" (1 PATH) ".")) (BUS 'SYSTEM-BUS))
148 (list (context) PATH NAME BUS))
150 ;; Method to clone a proxy for a given path/object.
151 (define (new-path PATH)
152 (list (context) PATH (%name) (%bus)))
154 ;; Update the connection serial and return it
155 (define (connection++)
157 (SYSTEM-BUS (:serial++ SYSTEM-BUS))
160 ;; marshalling functions and signal handling framework
161 ;; originallt lsp-dbus-marshal.lsp
163 ; The newlisp representation is a simplified form using lists for
164 ; structs and arrays.
166 ;; (expand-signature S)
167 ; Expland a signature string into a nested list to correspond to the
168 ; newlisp list representation.
169 ;; Basic dbus types are basic newlisp types, including strings. Arrays
170 ;; and structs are sublists; the expanded signature marks array
171 ;; sublists with an initial "a", otherwise it's a struct sublist.
173 ; Ex: "yi" = ("y" "i")
174 ; Ex: "y(ai)" = ("y" (("a" "i")))
175 ; Ex: "a(yi)" = (("a" ("y" "i")))
176 ; Ex: "yyyyuua(yv)" = ("y" "y" "y" "y" "u" "u" ("a" ("y" "v")))
177 (define (expand-signature S)
178 (setf S (replace "{" (replace "}" (copy S) ")") "("))
179 (let ((STACK '()) (CUR '()) (A 0))
180 (dolist (X (explode S))
182 (")" (setf X CUR) (setf CUR (pop STACK)))
183 ("(" (push CUR STACK) (setf CUR '()))
185 (when (and (!= X "a") (!= X "("))
186 (while (and CUR (= "a" (last CUR)))
187 (setf X (list (last CUR) X))
188 (setf CUR (chop CUR))))
191 (if (null? CUR) '() CUR)))
193 ;; Align AT to an I multiple and pad DATA with as many NUL bytes at
194 ;; front, then increment AT past it all.
195 (define (pack-align DATA (I (length DATA)))
196 (let ((PAD (dup "\000" (% (- I (% AT I)) I))))
197 (setf DATA (extend PAD DATA))
198 (inc AT (length DATA))
201 ;; Pack data from DATA according to signature. The DATA is a nested
202 ;; list where container types are sub lists. Variant types also appear
203 ;; as pairs of signature and value.
204 (define (pack-data SIGN DATA)
205 (let ((AT 0)) (pack-data-struct (expand-signature SIGN) DATA)))
207 ;; Pack a newlisp data element according to marshalling type The
208 ;; newlisp data is integer, double, string or list (for container and
209 ;; variant elements).
211 'FMTMAP ; mapping dbus type code to byte size and newlisp code
212 '( ("y" 1 "b") ; BYTE (unsigned 8-bit integer)
213 ("b" 4 "lu") ; BOOLEAN (0 is FALSE, 1 is TRUE, else invalid)
214 ("n" 2 "d") ; INT16 (signed 16-bit integer)
215 ("q" 2 "u") ; UINT16 (unsigned 16-bit integer)
216 ("i" 4 "ld") ; INT32 (signed 32-bit integer)
217 ("u" 4 "lu") ; UINT32 (unsigned 32-bit integer)
218 ("x" 8 "Ld") ; INT64 (signed 64-bit integer)
219 ("t" 8 "Lu") ; UINT64 (unsigned 64-bit integer)
220 ("d" 8 "lf") ; DOUBLE (64-bit float)
221 ("h" 4 "lu") ; UINT32 (unix file descriptor)
222 ("a" ? ?) ; ARRAY = UINT32 byte-length, items
223 ("s" ? ?) ; STRING = length + data + NUL
224 ("o" ? ?) ; OBJECT_PATH = BYTE length + data + NUL
225 ("g" ? ?) ; SIGNATURE = BYTE length + data + NUL
226 ("(" ? ?) ; STRUCT begin in signature = (8-align) + data
227 (")" 0 ?) ; STRUCT end in signature
228 ("v" ? ?) ; VARIANT = signature + data
229 ("{" ? ?) ; DICT_ENTRY begin
230 ("}" ? ?) ; DICT_ENTRY end
231 ("r" ? ?) ; reserved STRUCT in bindings?
232 ("e" ? ?) ; reserved DICT_ENTRY in bindings ?
233 ("m" ? ?) ; reserved 'maybe'
234 ("*" ? ?) ; reserved 'single complete type'
235 ("?" ? ?) ; reserved 'basic type'
242 (define (pack-data-item ES DATA)
243 (if (list? ES) (pack-data-struct ES DATA)
244 (= ES "s") (pack-data-string ES DATA)
245 (= ES "o") (pack-data-string ES DATA)
246 (= ES "g") (pack-data-signature ES DATA)
247 (= ES "v") (apply pack-data-variant DATA)
248 (if (lookup ES FMTMAP) (pack-align (pack $it DATA)))))
250 (define (pack-data-variant ES DATA)
251 (extend (pack-align (pack "bbb" 1 (char ES) 0) 1)
252 (pack-data-item ES DATA)))
254 ;; pack types "s" and "o"
255 (define (pack-data-string ES DATA)
256 (pack-align (pack (format "lus%db" (length DATA)) (length DATA) DATA 0) 4))
259 (define (pack-data-signature ES DATA)
260 (pack-align (pack (format "bs%db" (length DATA)) (length DATA) DATA 0) 1))
262 ;; Pack an array. DATA elements marshalled by repeating ES, preceded
263 ;; by the array length in bytes as aligned UINT32.
264 (define (pack-data-array ES DATA)
265 (let ((PAD (pack-align "" 4))
266 (X (inc AT 4)) ; start index of array bytes
267 (DATA (apply extend (map (curry pack-data-item ES) DATA))))
268 (extend PAD (pack "lu" (- AT X)) DATA)))
270 ;; Pack a struct. ES and DATA elements marshalled pairwise in order
271 ;; following an initial8-byte alignment.
272 (define (pack-data-struct ES DATA)
273 (if (= "a" (ES 0)) (pack-data-array (ES 1) DATA)
274 (apply extend (cons (pack-align "" 8)
275 (map pack-data-item ES DATA)))))
277 ;;########## unpacking
279 ;; Advance AT to an I multiple.
281 (inc AT (% (- I (% AT I)) I)))
283 ;; Advance AT to an I multiple and unpack (by newlisp format) at that
284 ;; position in DATA. Then advance AT further past that unpacking but
285 ;; return the unpacked value.
286 (define (unpack-align I FMT)
287 ##(println (list 'unpack-align I FMT AT (length DATA)))
289 ((fn (X) X) ((unpack FMT (AT DATA)) 0) (inc AT I)))
291 ;; Unpack a string or object path. The format is "lu" (UINT32) with
292 ;; the string length, then "s%db" with that string length and followed
294 (define (unpack-data-string ES (N (unpack-align 4 "lu")))
295 ((fn (X) X) ((unpack (string "s" N) (AT DATA)) 0) (inc AT (+ 1 N))))
297 ;; Unpack a signature string. The format is "b" (BYTE) with the string
298 ;; length, then "s%db" with that string length and followed by a NUL
299 ;; byte. I.e. the same as unpack-data-string but with the string
300 ;; length in a BYTE rather than an UINT32.
301 (define (unpack-data-signature ES)
302 (unpack-data-string ES (unpack-align 1 "b")))
304 ;; Unpack a variant item. This consists of "bbb" where the middle
305 ;; character is the type character for the data, preceded by a 1 byte
306 ;; and followed by a NUL byte. The subsequent data is unpacked
307 ;; according to that type character.
308 (define (unpack-data-variant)
309 (unpack-data-item ((expand-signature (unpack-data-signature "g")) 0)))
311 ;; Unpack the ES type item from (AT DATA), optionally with
312 ;; pre-alignment, and increment AT past the padding and item.
313 (define (unpack-data-item ES)
314 ##(println (list 'unpack-data-item ES AT (length DATA)))
315 (if (list? ES) (unpack-data-struct ES)
316 (= ES "s") (unpack-data-string ES)
317 (= ES "o") (unpack-data-string ES)
318 (= ES "g") (unpack-data-signature ES)
319 (= ES "v") (unpack-data-variant)
320 (if (assoc ES FMTMAP) (unpack-align ($it -2) ($it -1)))))
322 ;; Unpack array with ES elements. The array begins with an UINT32
323 ;; field telling how many bytes to unpack, followed by the array
325 (define (unpack-data-array ES)
326 (let ((A AT) (N (+ (unpack-align 4 "u") AT)) (OUT '()))
327 (when (and (list? ES) (!= "a" (ES 0))) (align-AT 8))
329 ##(println "---next " (list AT N))
330 (push (unpack-data-item ES) OUT -1))
333 ;; Unpack a structure or array with ES fields.
334 (define (unpack-data-struct ES)
335 ##(println (list 'unpack-data-struct ES AT))
336 (if (= "a" (ES 0)) (unpack-data-array (ES 1))
337 (begin (align-AT 8) (map unpack-data-item ES))))
339 ;; Unpack from a DATA string according to signature SIGN This returns
340 ;; a pair (unpacked pos) of unpacked data and how much data is
342 (define (unpack-data SIGN DATA (AT 0))
343 ##(println (format "*** unpack-data %s %d %d" SIGN (length DATA) AT))
344 (list (unpack-data-item (expand-signature SIGN)) AT))
346 ;; Unpack all dbus messages in the given DATA block. Each message
347 ;; consists of head and body. The head has signature "yyyyuua(yv)"
348 ;; where the array is an alist of key-value pairs, optionally
349 ;; including the 'SIGNATURE key with the signature for the body; if
350 ;; omitted, then the body is empty.
352 ;; The function returns the header list of key-value pairs optionally
353 ;; extended with the pair ("" body).
354 (define (unpack-messages DATA)
355 (let ((AT 0) (OUT '()) (M nil) (D nil) (S nil))
356 (while (and (< (+ AT 7) (length DATA))
357 (setf M (unpack-data "yyyyuua(yv)" DATA AT)))
359 ##(println "message head " (M 0))
360 ##(println (list 'remains AT (length DATA)))
361 (setf M (M 0 -1)) ; Drop all but the headers then map to symbol keys
362 (dotimes (i (length M))
363 (setf (M i 0) (MESSAGE-HEADERS (M i 0) 0)))
364 ##(println "mapped headers " M)
365 ;; Add the body, if any, keyed by "".
366 (setf S (if (lookup 'SIGNATURE M) $it ""))
367 ##(println (list 'sign S))
368 (when (and (!= S "") (setf D (unpack-data S DATA AT)))
370 (extend M (list (list "" (D 0)))))
371 ;; Collate message and move to the next portion in DATA
373 ##(println (list 'ending AT (length DATA)))
375 ##(println (list 'aligned AT (length DATA)))
376 (setf DATA (AT DATA))
381 #################################################################
382 ;; Originally lsp-dbus-events.lsp
384 ;; This newlisp module implements dbus socket send-receive together
385 ;; with signal receive. (This file should be loaded into the Dbus
388 ;; The REPL loop is re-mastered by means of a prompt-event function
389 ;; that firstly handles any pending dbus messages, and secondly
390 ;; net-select on both the dbus socket and stdin.
392 ;; Stdin is handled with priority.
394 ;; Dbus messages are read and added to the pending list.
396 ;; Handlers are set up as functions (fn (data msg) ..) identified by
397 ;; "dbus callback key" consisting of path, interface, method and
398 ;; signature separated by ":". For example:
400 ;; "/org/freedesktop/DBus:org.freedesktop.DBus.NameAcquired(s)"
402 ;; would identify the handler for the NameAcquired(string) method of
403 ;; the interface "org.freedesktop.DBus" of the path
404 ;; "/org/freedesktop/DBus" of the client. That particular callback is
405 ;; a s.c. signal sent by the dbus framework implementation in reaction
406 ;; to the initial Hello call, i.e. the s.c. invocation of
408 ;; "/org/freedesktop/DBus:org.freedesktop.DBus.Hello()"
411 ;; Return the callback key for a message MSG
412 (define (message-key MSG)
413 (string (lookup 'PATH MSG) ":" (lookup 'INTERFACE MSG) "."
414 (lookup 'MEMBER MSG) "(" (lookup 'SIGNATURE MSG) ")" ))
416 ;; This is the table of handlers, keyed by path:interface:method:signature
417 (define RECV:RECV nil)
419 ;; Utility function to install a handler for a given key,
420 (define (handler KEY HANDLER)
421 (RECV (string (%path) ":" KEY) HANDLER))
423 ;; This is the list of Dbus messages still to handle.
426 (define (no-handler KEY MSG)
427 (write-line 2 (format "** No handler %s for:\n%s" KEY (string MSG))))
429 (define (process-message MSG)
430 (let ((KEY (message-key MSG)))
431 (if (RECV KEY) ($it (lookup "" MSG))
432 (no-handler KEY MSG))))
434 ;; Process all messages currently pending
435 (define (process-all-pending)
436 (while (if (pop pending) (process-message $it))))
438 ;; The main-loop is intended as a prompt-handler so as to deal with
439 ;; asyncronous events
440 (define (main-loop S)
441 (let ((FDS (list 0 (:%socket SYSTEM-BUS))) (FD nil))
442 (write 2 (string "> "))
443 (while (or pending (not (member 0 (net-select FDS "r" -1))))
444 (if (pop pending) (process-message $it)
445 (if (unpack-messages (or (:read-message SYSTEM-BUS) ""))
446 (extend pending $it))
450 (define (human-msg MSG)
451 (human-bytes (unpack (dup "b" (length MSG)) MSG)))
453 ;; Send message, then keep reading messages until there is a reply
454 (define (send-recv-message MSG)
455 ;;(die nil (list 'send-recv-message (human-msg MSG)))
456 (net-send (:%socket SYSTEM-BUS) MSG)
459 (dolist (M (unpack-messages (:read-message SYSTEM-BUS)))
460 (if (lookup 'REPLY_SERIAL M) (setf REPLY M)
461 (push M pending -1))))
465 ;; ====================
469 'PROTOCOL-VERSION '(1 1)
470 'MESSAGE-TYPES '(INVALID METHOD_CALL METHOD_RETURN ERROR SIGNAL)
471 'MESSAGE-FLAGS '(NO_REPLY_EXPECTED
473 ALLOW_INTERACTIVE_AUTHORIZATION)
474 ;; Message headers: [code] => (name type)
475 'MESSAGE-HEADERS '((INVALID )
488 ;; Map message type symbol to dbus type code (i.e. the list index)
489 (define (message-type-code TYPE)
490 (or (find TYPE MESSAGE-TYPES =) 0))
492 ;; Map flag symbol F to its dbus "bit code"
494 (if (find F MESSAGE-FLAGS) (pow 2 $it) 0))
496 ;; Return the dbus flags code from FLAGS; if it is a number thent tha
497 ;; is returned as is; if FLAGS is a list of message flag symbols then
498 ;; combine their codes by bit-OR. Anything else yields 0.
499 (define (message-flags FLAGS)
500 (if (number? FLAGS) FLAGS
502 (apply | (map flag FLAGS))
505 ;; (message-header (NAME VALUE))
506 ; Translate header into its marshalling data. The name is mapped to
507 ; its header code and associated value type. This gets translated into
508 ; the marshalling data form of (code (type value))
509 (define (message-header HDR)
511 (if (find (list (HDR 0) '*) MESSAGE-HEADERS match)
512 (list $it (list (MESSAGE-HEADERS $it -1) (HDR 1))))))
514 ;; Join the excess string arguments N-byte alignment successively
518 (let ((PAD (dup "\000" (% (- N (% (length OUT) N)) N))))
522 ;; Return a marshalled message string appended by the marshalled body
523 (define (message TYPE FLAGS HDRS BODY)
525 (pack-data "yyyyuua(yv)"
527 (message-type-code TYPE)
528 (message-flags FLAGS)
529 (PROTOCOL-VERSION 0) ; Major version code
532 (clean null? (map message-header HDRS))))
535 ;; (:invoke OBJ METHOD ARGS FLAGS)
536 ; Perform a METHOD_CALL on the (self) object
537 ;; The given METHOD has format "INTERFACE.NAME(SIGNATURE)" with the
538 ;; "INTERFACE." bit optional. The function returns the list of headers
539 ;; of the reply message extended with reply value as a faked header
542 ;; This function calls send-recv-message which also polls for signals
543 ;; until a reply is given, but any such signals are stocked up as
544 ;; pending for later processing on demand.
545 (define (invoke METHOD ARGS (FLAGS 0))
546 (when (regex "((.+):)?((.+)\\.)?([^(]+)\\((.*)\\)$" METHOD 0)
547 (let ((PATH $2) (INTERFACE $4) (MEMBER $5) (SIGNATURE $6))
548 ;;(println (list 'invoke (%name) INTERFACE MEMBER SIGNATURE))
549 (if (message 'METHOD_CALL FLAGS
550 (list nil ; (if SELF-NAME (list 'SENDER SELF-NAME))
551 (list 'DESTINATION (%name))
552 (list 'PATH (if (empty? PATH) (%path) PATH))
553 (if (empty? INTERFACE) nil
554 (list 'INTERFACE INTERFACE))
555 (list 'MEMBER MEMBER)
556 (if (empty? SIGNATURE) nil
557 (list 'SIGNATURE SIGNATURE))
559 (if (empty? SIGNATURE) ""
560 (pack-data SIGNATURE ARGS)))
561 (send-recv-message $it)
565 ;; Context variables and framework registration
567 SYSTEM-BUS (MAIN:DbusConnection "/run/dbus/system_bus_socket")
568 APPID (:initialize SYSTEM-BUS)
569 ROOT (Dbus "/org/freedesktop/DBus")
570 DBus (DbusInterface "org.freedesktop.DBus")
571 APPNAME (if (:invoke ROOT (:m DBus "Hello()"))
575 ;; Installation of some framework notification handlers
577 ;; Helper method to notify
578 (define (signal-trace ARGS)
579 (die nil "** Got:" KEY ARGS ))
581 (:handler ROOT (:m DBus "NameAcquired(s)") signal-trace)
582 (:handler ROOT (:m DBus "NameLost(s)") signal-trace)
583 (:handler ROOT (:m DBus "NameOwnerChanged(sss)") signal-trace)
585 ; Process notifications that came with the registration handshake
586 (process-all-pending)
588 ;; Set up the Dbus event loop as prompt-event handler
589 (prompt-event Dbus:main-loop)
591 ;;######################################################################
593 ;; Standard interfaces
597 (:use (DbusInterface "org.freedesktop.DBus.Peer"
602 (:use (DbusInterface "org.freedesktop.DBus.ObjectManager"
603 '( "GetManagedObjects():a(oa(sa(sv)))"
606 (:use (DbusInterface "org.freedesktop.DBus.Introspectable"
607 ' Introspectable "Introspect():s" ; (xml data)
609 ; https://dbus.freedesktop.org/doc/dbus-specification.html#introspection-format
611 (:use (DbusInterface "org.freedesktop.DBus.Properties"
615 "PropertiesChanged(sa(sv)as):" ; signal ?
618 (:use (DbusInterface "org.freedesktop.DBus"
622 "ListQueuedOwners (s):as"
624 "ListActivatableNames():as"
626 "NameOwnerChanged(sss):" ; -- signal
627 "NameLost(s):" ; -- signal
628 "NameAcquired(s):" ; -- signal
629 "ActivatableServicesChanged():" ; -- signal
630 "StartServiceByName(s,u):u"
631 "UpdateActivationEnvironment(a(ss)):"
633 "GetConnectionUnixUser(s):u"
634 "GetConnectionUnixProcessID(s):u"
635 "GetConnectionCredentials(s):a(sv)"
636 "GetAdtAuditSessionData(s):ay"
637 "GetConnectionSELinuxSecurityContext(s):ay"
641 "Monitoring.BecomeMonitor(asu):"
644 ;eg AddMatch argument:
645 ;"type='signal',sender='org.example.App2',path_namespace='/org/example/App2'"