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:DbusConnection) (load "lsp-dbus-connection.lsp"))
16 #################################################################
19 ; Include marshalling functions
20 (load "lsp-dbus-marshal.lsp" MAIN:Dbus)
22 ;; Declaring the FOOP object
26 (setf SYSTEM-BUS (MAIN:DbusConnection "/run/dbus/system_bus_socket"))
27 (:initialize SYSTEM-BUS)
29 ;; "Constructor". Creates an adapter object for a given base path.
30 (define (Dbus:Dbus PATH (BUS 'SYSTEM-BUS))
31 (list (context) PATH BUS))
33 ;; Return the bus name
35 (join (find-all "([^/]+)" (%path) $1 0) "."))
37 ;; Return the DbusConnection connection adapter
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 ;; Determine the type code = index of teh type symbol in the
65 ;; MESSAGE-TYPES list.
66 (define (message-type-code TYPE)
67 (or (find TYPE MESSAGE-TYPES =) 0))
70 (if (find F MESSAGE-FLAGS) (pow 2 $it) 0))
72 ;; Combining header flag symbols into the flags code = bit-or of the
73 ;; 2^x values where x is the index for the flag symbol in the
74 ;; MESSAGE-FLAGS list.
75 (define (message-flags FLAGS)
76 (if (number? FLAGS) FLAGS
77 (list? FLAGS) (apply | (map flag FLAGS))
80 ;; (message-header (NAME VALUE))
81 ; Translate header into its marshalling data. The name is mapped to
82 ; its header code and associated value type. This gets translated into
83 ; the marshalling data form of (code (type value))
84 (define (message-header HDR)
85 (let ((CODE (find (list (HDR 0) '*) MESSAGE-HEADERS match) 0))
86 (list CODE (list (MESSAGE-HEADERS CODE 1) (HDR 1)))))
88 ;; Return a marshalled message
89 (define (message TYPE FLAGS HDRS BODY)
91 (pack-data "yyyyuua(yv)"
93 (message-type-code TYPE)
95 (PROTOCOL-VERSION 0) ; Major version code
97 (:serial++ (connection))
98 (map message-header HDRS)))
101 (define (method-body ARGS)
104 ;; Invoke a method on an object via dbus
105 ; (:invoke OBJ MEMBER INTERFACE FLAGS)
106 (define (invoke MEMBER INTERFACE (FLAGS 0))
107 (or INTERFACE (setf INTERFACE (bus-name)))
108 (if (message 'METHOD_CALL FLAGS
109 (list (list 'PATH (%path))
110 (list 'DESTINATION (bus-name))
111 (list 'INTERFACE INTERFACE)
112 (list 'MEMBER MEMBER))
113 (method-body (args)))
115 (let ((MSG $it) (BUFFER "") (RESULT "") (S (:%socket (connection))))
117 (while (net-select S "r" 1000)
118 (net-receive S BUFFER 8192)
119 (extend RESULT BUFFER))